bonjour,

grâce à l'aide de plusieurs d'entre vous j'ai maintenant un fichier excel avec une macro vba qui me permet d'envoyer une sélection par mail.
mon fichier contient plusieurs feuilles et la macro envoie une plage à un destinataire différent correspondant à chaque feuille.

sauf que cela fonctionne sans problème sur certaines feuilles, et puis sur d'autres ça me fait un grand carré blanc (des fois il y a le tableau dedans) que je ne peux pas enlever, et ça m'affiche une erreur 438 !
si sur une feuille où ça ne fonctionnais pas je change la sélection des cellules, alors ça fonctionne! sauf qu'il faut que j'envoie cette plage et que j'aimerai bien que le problème ne se reproduise pas...


Pourquoi cela déconne que sur certaines feuilles? et comment pourrais je supprimer cette erreur?

voilà mon code, en espérant que certains seront inspirés :p Merci beaucoup !

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
 
Sub Envois_récap()
Application.ScreenUpdating = False
    Dim iMsg As Object, iConf As Object, Flds As Object, strHTML As String, i As Byte, j As Byte, nompdf As String, PLAGE As Range
 
    nompdf = "C:\Users\" & Environ("Username") & "\Desktop\" & "recap.pdf"
    Set PLAGE = ActiveSheet.Range("s1:ae43")
    PLAGE.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nompdf, Quality:=xlQualityMinimum, IncludeDocProperties:=True, _
                              IgnorePrintAreas:=False, OpenAfterPublish:=False
    codehtml = range_to_html_sans_codagehtml3(PLAGE, True, True)
 
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    Set Flds = iConf.Fields
 
    strHTML = ""
    strHTML = strHTML & "<HEAD>" & vbCrLf & "<BODY>" & "Bonjour, <BR><BR>Voici le récap du mois et ci-joint la version pdf.<BR><BR>"
    strHTML = strHTML & codehtml
    strHTML = strHTML & "<BR><BR>Cordialement."
    strHTML = strHTML & "</BODY>"
    strHTML = strHTML & ""
 
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.orange.fr"
        .Update
    End With
 
    With iMsg
        Set .Configuration = iConf
        .To = Range("A47").Value
        .From = "moi@hotmail.fr"
        .Subject = "Récapitulatif"
        .HTMLBody = strHTML
        .AddAttachment nompdf
        .Send
    End With
    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
    Set PLAGE = Nothing
End Sub
Function range_to_html_sans_codagehtml3(Optional rng As Range = Nothing, Optional correction As Boolean = False, Optional show_grid_line As Boolean = False) As String
    Dim myWebBrowser, wb, i As Long, mesTD As Object, codebase As String, dico, a As Long, docw, Doc, lig As Long, col As Long, mesTR
    Dim Table, L As Long, c As Long, TR, TD, V, VRL, TA, TAL, TxT As String
    Set dico = CreateObject("scripting.dictionary")
    If rng Is Nothing Then Set rng = Application.InputBox(prompt:="Sample", Type:=8)
    Set myWebBrowser = ActiveSheet.OLEObjects.Add(ClassType:="Shell.Explorer.2", Left:=2000, Top:=1, Width:=700, Height:=800)
    myWebBrowser.Activate:
    Set wb = myWebBrowser.Object
 
    rng.Copy
    With wb
        Set docw = .Document
        Set Doc = CreateObject("htmlfile")
        .Silent = True: .Navigate "about:blank":
        .Document.write "<html><body><br><div id=""calque"" contenteditable=true style=""width:80%;height:80%;""></div></body></html>"
        .Document.getelementbyid("calque").Focus
        .Document.execcommand "paste", False, Null    'j'execute la commande javascript "Paste"
        Set mesTD = .Document.getelementsbytagname("TD")    'je collectionne tout les balises "TD"
        'je vais donner a chaque TD(cellules HTML) l'adresse de la cellules excel corepondante
        ' comme ca je peut manipuler les td en fonction de leur ID (voir la suite du code )
        For lig = rng.Row To rng.Rows.Count + rng.Row - 1
            For col = rng.Column To rng.Column + rng.Columns.Count - 1
                If Not dico.exists(Cells(lig, col).MergeArea.Address) Then
                    dico(Cells(lig, col).MergeArea.Address) = ""
                    a = a + 1: mesTD(a - 1).ID = Cells(lig, col).MergeArea.Address
                End If
            Next
        Next
        'le copy/javascript.paste ne gere pas certaine choses on va donc corriger tout ses details
        If correction = False Then GoTo passe
        Set mesTR = .Document.getelementsbytagname("TR")
        With Doc
            .write "<TABLE ID = ""tablo""></TABLE>": Set Table = .getelementbyid("tablo")
            With Table: .Style.Width = Round(rng.Width * 1.6666666) & "px": .cellspacing = 15: .cellpadding = 0: .Style.tablelayout = "fixed": .Style.bordercollapse = "collapse": End With
            For L = 0 To mesTR.Length - 1
                Set mesTD = mesTR(L).getelementsbytagname("TD")
                Set TR = .createElement("TR"): Table.appendchild (TR)
                For c = 0 To mesTD.Length - 1
                    Set TD = Doc.createElement("TD")
                    TR.appendchild (TD)
 
                    'on reprends les bordures
                    TD.Style.borderleft = mesTD(c).Style.borderleft: TD.Style.borderright = mesTD(c).Style.borderright
                    TD.Style.bordertop = mesTD(c).Style.bordertop: TD.Style.borderbottom = mesTD(c).Style.borderbottom
                    If TD.Style.borderleft Like "*dashed*" Then TD.Style.borderleft = "1.5pt dashed " & Split(TD.Style.borderleft, " ")(0)
                    If TD.Style.borderright Like "*dashed*" Then TD.Style.borderright = "1.5pt dashed " & Split(TD.Style.borderright, " ")(0)
                    If TD.Style.bordertop Like "*dashed*" Then TD.Style.bordertop = "2pt dashed " & Split(TD.Style.bordertop, " ")(0)
                    If TD.Style.borderbottom Like "*dashed*" Then TD.Style.borderbottom = "2pt dashed " & Split(TD.Style.borderbottom, " ")(0)
 
                    If TD.Style.borderleft Like "*dotted*" Then TD.Style.borderleft = "1.5pt dotted " & Split(TD.Style.borderleft, " ")(0)
                    If TD.Style.borderright Like "*dotted*" Then TD.Style.borderright = "1.5pt dotted " & Split(TD.Style.borderright, " ")(0)
                    If TD.Style.bordertop Like "*dotted*" Then TD.Style.bordertop = "1.5pt dotted " & Split(TD.Style.bordertop, " ")(0)
                    If TD.Style.borderbottom Like "*dotted*" Then TD.Style.borderbottom = "1.5pt dotted " & Split(TD.Style.borderbottom, " ")(0)
 
 
                    ' on dimenssionne au plus proche du réel
                    TD.ID = mesTD(c).ID: TD.rowspan = mesTD(c).rowspan: TD.colspan = mesTD(c).colspan
                    TD.Style.Width = Round(Range(TD.ID).Width * 1.66666666) & "px"
                    TD.Style.Height = Round(Range(TD.ID).Height * 1.66666666) & "px"
                    '***********************************************************
 
 
 
 
                    TD.Style.backgroundcolor = mesTD(c).Style.backgroundcolor
 
                    ' on ajoute le wraptext excel le copy/javascript.paste  ne le fait  pas
                    If Range(TD.ID).WrapText Then TD.Style.WordWrap = "break-word"
                    V = Range(TD.ID).VerticalAlignment: VRL = Switch(V = xlTop, "top", V = xlBottom, "bottom", V = xlCenter, "middle"): TD.Style.verticalAlign = VRL
                    TA = Range(TD.ID).HorizontalAlignment: TAL = Switch(TA = xlLeft, "left", TA = xlCenter, "center", TA = xlRight, "right"): If Not IsNull(TAL) Then TD.Style.textAlign = TAL
                    TD.innerhtml = mesTD(c).innerhtml
 
                    'on applique le marginleft et right  a l'identique des cellules excel le copy/javascript ne l'a pas respecté
                    'corection des marginright et marginleft du texte dans les cellules HTML
                    If TD.Children.Length > 0 Then
                        For i = 1 To TD.Children.Length - 1
                            TD.Children(i).Style.margin = "0.5pt"
                        Next
                        TD.LastChild.Style.MarginRight = "3px": TD.FirstChild.Style.MarginLeft = "3px"
                    Else
                        If TD.innertext <> "" Then TD.FirstChild.Style.MarginRight = "3px"
                    End If
                Next
                TxT = Doc.body.innerhtml
 
            Next
        End With
        Debug.Print TxT
        range_to_html_sans_codagehtml3 = TxT
 
        GoTo suite
 
passe:
        range_to_html_sans_codagehtml3 = .Document.body.innerhtml
suite:
        range_to_html_sans_codagehtml3 = IIf(show_grid_line, Replace(range_to_html_sans_codagehtml3, "#f0f0f0", "0.1pt solid #CED8F6"), range_to_html_sans_codagehtml3)
 
 
    End With
    myWebBrowser.Delete
    Application.CutCopyMode = False: Application.CutCopyMode = True    'on debloque la plage en pointillés (due a copy)
 
End Function