Sauvegarder image userform

Version imprimable

Voir 40 message(s) de cette discussion en une page

26/10/2017, 10h20
Denis_67

Bonjour Patrick,

Effectivement j'avais le unlod me qui était encore actif ! désolé.

Par contre l'image ne se sauvegarde pas.
Par conre J'ai toujours cette erreur le code s'arrête sur Set shap = .Shapes(shapecount)
'-2147024809(80070057)"L'index de cette collection est en dehors des limites"

Denis

re
tu dois certainement avoir une protection sur feuille

bon allez on passe plus par un paste copie directement full api
change tout le code du module pour celui ci et on en parle plus

Code:

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
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData& Lib "User32" (ByVal wFormat%)
Private Declare Function GetDC Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "User32" (ByVal hwnd As Long, ByVal Hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal Hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal Hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal Hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal Hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal Hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal Hdc As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetForegroundWindow Lib "User32" () As Long
Private Declare Function GetDesktopWindow Lib "User32" () As Long
Private Declare Function GetActiveWindow Lib "User32" () As Long
Private Declare Function GetWindowRect Lib "User32" (ByVal hwnd As Long, lpRect As RECT) As Long
' api creation object image
Private Declare Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
'rectangle
Type RECT: Left As Long: Top As Long: Right As Long: BOTTOM As Long: End Type
'guid all propertie pour le jpg
Type GUID: Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(8) As Byte: End Type
' info image
Private Type PICTDESC: cbSize As Long: picType As Long: hImage As Long: End Type
Const SRCCOPY = &HCC0020
Public chemin_image As String
Sub captur_USERFORM(usf)
    Dim ActiveHwnd As Long, DeskHwnd As Long, Hdc As Long, hdcMem As Long, RECT As RECT, action As Long, fwidth As Long, fheight As Long
    Dim hBitmap As Long, iPic As IPicture, hCopy&, tIID As GUID, tPICTDEST As PICTDESC, Ret As Long
    '---------------------------------------------------
    DeskHwnd = GetDesktopWindow(): ActiveHwnd = GetActiveWindow()    ' determination du handle de la fentre active et du bureau
    '---------------------------------------------------
    '---------------------------------------------------
    'determination du rectangle de capture avec les coordonnée de la fenetre active
    Call GetWindowRect(ActiveHwnd, RECT)
    fwidth = (RECT.Right - RECT.Left): fheight = (RECT.BOTTOM - RECT.Top)
    '---------------------------------------------------
    '---------------------------------------------------
    ' determination du contexte HDC du desktop et creation du bitmap avec son HDC
    Hdc = GetDC(DeskHwnd)
    hdcMem = CreateCompatibleDC(Hdc)
    hBitmap = CreateCompatibleBitmap(Hdc, fwidth - 9, fheight - 24)
    '---------------------------------------------------
    If hBitmap <> 0 Then
        SelectObject hdcMem, hBitmap
        BitBlt hdcMem, 0, 0, fwidth - 9, fheight - 24, Hdc, RECT.Left + 4.5, RECT.Top + 24, SRCCOPY
        '---------------------------------------------
        ' vidage et mise en memoire de l'image bitmap dans le clipboard
        OpenClipboard 0: EmptyClipboard: SetClipboardData 2, hBitmap: CloseClipboard
        '---------------------------------------------
    End If
    '                                                 SAUVEGARDE DE L IMAGE
    chemin_image = Environ("userprofile") & "\Desktop\" & usf.Name & ".jpg"
    OpenClipboard 0&
    hCopy = CopyImage(GetClipboardData(&H2), 0, 0, 0, &H8)
    CloseClipboard
    If hCopy = 0 Then Exit Sub
    Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
    Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
    If Ret Then Exit Sub
    With tPICTDEST: .cbSize = Len(tPICTDEST): .picType = 1: .hImage = hCopy: End With
    Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
    If Ret Then Exit Sub
    SavePicture iPic, chemin_image    'on enregistre le cliché
    '---------------------------------------------
    ' Clean up handles
    DeleteDC hdcMem: ReleaseDC DeskHwnd, Hdc
    '---------------------------------------------
End Sub

a la fin de ta macro mail Outlook met

Code:

kill chemin_image

voila

27/10/2017, 19h22
Denis_67

M.E.R.C.I PATRICK

Voilà ça fonctionne !!!!

Je valide mes USF, et j'envoie un mail avec l'image de l'USF dans le corps de message outlook.

C'est nickel !
La dernière erreur venait de nos différents échanges et tests, je n'avais pas bien supprimé les différens essais.
Tu me tires une sacrée épine du pied, j'ai maintenant une solution valide qui me permet de finaliser mes USF.

Par contre je suis quand même frustré que ton super cote de transformation de l'USF en HTML ne soit pas utilisable. ce qui me plait c'est qu'il n'utilise auqune API
M'autorises tu à re réer un post sur le sujet envoyer un "createobject("html") dans une corps de message outlook?

En tout cas enore un énormer merci
Denis
27/10/2017, 19h32
patricktoulon

re

re
de rien ca m'a permis de chercher une autre solution que la touche print pour capturer
le pire c'est que je l'avais dans mes archives
je l'ai un peu remanier et en ai fait une petite contrib bien sympa

Citation:

M'autorises tu à re réer un post sur le sujet envoyer un "createobject("html") dans une corps de message Outlook?

on envoie pas l'object il sert simplement a créer les élément dans un document html virtuel en mémoire

ouvre un nouveau post
et si tu est prêt a reprendre tout tes userforms je te montrerais comment y arriver
il suffit de nommer tout tes control d'une certaine manière

tu m'aura fait transpirer:mouarf:
28/10/2017, 09h13
Denis_67

Sauvegarde

Oui justement j ai essayé de sauvegarder la page IE affichée au format htm.
Puis je l'ai envoyée en pj. Mais j'ai obtenu un beau roman en ideogramme!
Si on avait pu recuperer le contenu ca aurait ete interessant.
J'ai un peu peur quand je vais diffuser le full api davoir des pb avec des utilisateurs.
On a beau avoir des pc super brides et les versions de soft installé depuis un système central,on se retrouve quand meme avec des versions differentes suivant les utilisateurs exemple office 2013 ou 2016.
28/10/2017, 09h57
patricktoulon

re

oui comme je te l'ai dis je l'ai fait en 32 bit pour les api
maintenant une image reste une image 32 ou 64 bit la dernier solution full api devrai envoyer l'image et tout les destinataire devraient pouvoir la voir
cette dernière solution n'utilise plus le paste et copie sur sheet c'est du direct (création avec api de l'image/fichier)

maintenant en html oui tu a du voir le code html :ptdr:

mais dans un mail il est représenté comme élément donc visionnable

je m'occupe de te faire un exemple avec echapébelle sans api en html comme tu comprendra ce que tu aurais du faire depuis le début a savoir identifier tes controls d'une certaine manière plutôt que de leur donner des nom qui m'empêche de dormir :ptdr:

Plage _to_HTML Format police

Bonjour Patrick,

J'ai un cas (ou deux) ou je vais utiliser l'autre possibilité que tu as développé à savoir Plage_to_HTML.

Je pars d'une feuille et je génère un tableau HTML correspondant dans mon corps de mail.
Ma question est, peut-on adapter la taille de la police dans l'HTML
Sur ma feuille Excel j'ai police Arial 10 et dans le message je suis en 13.
J'ai bien vu des séquences : Font.Size + 7 & "px" Mais comme je ne veux pas modifier ton code, je préfère te demander.
Merci
Denis

Rappel du code

Code:

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
 
Function plage_to_HTML(plage As Range) As String
    Dim TD, TR, DOC, DICO, Table As Object, i As Long, col As Long, cel As Range, Halign, Valign
    Set DICO = CreateObject("scripting.dictionary")
    Set DOC = CreateObject("htmlfile")
    With DOC
        .body.innerhtml = "<Table align=center></Table>"
        Set Table = .getelementsbytagname("Table")(0)
        Table.Style.Width = Round(plage.Width * (4 / 2.4))
        Table.Style.Height = Round(plage.Height * 1.75)
        Table.Style.bordercollapse = "collapse"
        Table.Style.letterSpacing = "0.5pt"
        Table.Style.Display = "inline"
        For i = 1 To plage.Rows.Count
            Set TR = .createelement("TR")
            For col = 1 To plage.Columns.Count
                Set cel = plage.Cells(i, col)
 
                If Not DICO.exists(cel.MergeArea.Address) Then
                    DICO(cel.MergeArea.Address) = ""
                    Set TD = .createelement("TD")
                    With TD
                        .ID = cel.Address: .colspan = cel.MergeArea.Columns.Count: .rowspan = cel.MergeArea.Rows.Count
 
                        .innerhtml = IIf(cel.Value <> "", text_BYSPAN_format(cel), "   ")
                        With .Style
                            .FontSize = IIf(IsNull(cel.Font.Size), 20, Round(cel.Font.Size + 7)) & "px"
                            .fontfamily = cel.Font.Name
                            .fontweight = IIf(cel.Font.Bold = True, "Bold", "Normal")
                            .FontStyle = IIf(cel.Font.Italic = True, "italic", "normal")
                            .Color = IIf(IsNull(cel.Font.Color), 0, coul_XL_to_coul_HTMLX(cel.Font.Color))
                            .bordertop = borderstyle(cel.borders(xlEdgeTop))
                            .borderleft = borderstyle(cel.borders(xlEdgeLeft))
                            .borderbottom = borderstyle(cel.borders(xlEdgeBottom))
                            .borderright = borderstyle(cel.borders(xlEdgeRight))
                            .Width = Round(cel.Width * 1.5)
                            .Height = Round(cel.Height * 1.5) & "px"
                            .Background = coul_XL_to_coul_HTMLX(cel.Interior.Color)
                            Halign = Switch(IsNull(cel.HorizontalAlignment), "left", cel.HorizontalAlignment = xlRight, "right", cel.HorizontalAlignment = -4108, "center", cel.HorizontalAlignment = -4107, "left")
                            Valign = Switch(IsNull(cel.VerticalAlignment), "middle", cel.VerticalAlignment = xlTop, "top", cel.VerticalAlignment = xlCenter, "middle", cel.VerticalAlignment = xlBottom, "bottom")
                            .textalign = IIf(IsNull(Halign), "left", Halign)
                            .verticalalign = IIf(IsNull(Valign), "middle", Valign)
                        End With
                    End With
                    TR.appendchild (TD)
                End If
            Next
            Table.appendchild (TR)
        Next
        plage_to_HTML = .body.innerhtml
    End With
End Function
Function coul_XL_to_coul_HTMLX(couleur)
    Dim str0 As String, str As String
    'If couleur = 16777215 Then couleur = vbWhite
    str0 = Right("000000" & Hex(couleur), 6)
    str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
    coul_XL_to_coul_HTMLX = "#" & str & ""
End Function
Function borderstyle(Cote)
    Dim borderweight, bstyle As String, bcolor As String
    borderweight = Switch(Cote.Weight = 1, 1, Cote.Weight = 2, 1, Cote.Weight = -4138, 2, Cote.Weight = 4, 3) & "px  "
 
    bstyle = IIf(Cote.LineStyle <> 1, "dashed", "solid")
    If Cote.LineStyle = xlDash And Cote.Weight = xlThick Then borderweight = 3    ' xldash et epaisseur xlthick   'Tiret en pointillet
    If Cote.LineStyle = xlDash And Cote.Weight = xlThin Then borderweight = 2:: bstyle = "dotted"     'point  en pointillet
    If Cote.LineStyle = xlDashDotDot Then borderweight = 3    'xlDashDotDot
    bcolor = coul_XL_to_coul_HTMLX(Cote.Color)
    borderstyle = borderweight & bstyle & "  " & bcolor
    If Cote.LineStyle = xlNone Then borderstyle = "0.3pt solid #A9D0F5"
End Function
Function text_BYSPAN_format(c)
'formatage du texte de la cellule html identiquement a la cellule excel
    Dim p As Object, oldspan As Object, i As Long, L, formatcell
    formatcell = c.NumberFormat
    If IsNumeric(c.Value) And c.NumberFormat <> "@" Then text_BYSPAN_format = "&nbsp;" & c.Text: Exit Function
    text_BYSPAN_format = ""
    With CreateObject("htmlfile")
        .body.innerhtml = "<div id =T><SPAN> </SPAN></div>"
        Set p = .getelementbyid("T")
        Set oldspan = .getelementsbytagname("SPAN")(0)
        For i = 1 To Len(c.Value)
            Set L = .createelement("span")
            L.Style.Color = coul_XL_to_coul_HTMLX(c.Characters(Start:=i, Length:=1).Font.Color)
 
            L.Style.FontSize = c.Characters(Start:=i, Length:=1).Font.Size + 7 & "px"
 
            L.Style.fontfamily = c.Characters(Start:=i, Length:=1).Font.Name
            L.Style.fontweight = IIf(c.Characters(Start:=i, Length:=1).Font.Bold = True, "Bold", "Normal")
            L.Style.FontStyle = IIf(c.Characters(Start:=i, Length:=1).Font.Italic = True, "italic", "normal")
 
            If Split(L.outerhtml, ">")(0) <> Split(oldspan.outerhtml, ">")(0) Then
                L.innertext = c.Characters(Start:=i, Length:=1).Text
                p.appendchild (L)
                Set oldspan = L
            Else
                oldspan.innertext = oldspan.innertext & c.Characters(Start:=i, Length:=1).Text
            End If
        Next
 
        text_BYSPAN_format = "&nbsp;" & .getelementsbytagname("div")(0).innerhtml
    End With
 
End Function
Sub test_byspan()
    text_BYSPAN_format ([b4])
    Set IE = CreateObject("internetexplorer.application")
    IE.Visible = True
    IE.navigate "about:blank"
    IE.document.body.innerhtml = text_BYSPAN_format([b4])
End Sub
Sub testcharacter()
    Dim c As Range
    Set c = [B10]
    MsgBox c.Formula
End Sub

re

bonjour denis
oui on peu adapter la taille mais ton code c'est pas bon du tout
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Table.Style.Width = Round(plage.Width * (4 / 2.4)) Table.Style.Height = Round(plage.Height * 1.75) Table.Style.bordercollapse = "collapse" Table.Style.letterSpacing = "0.5pt" Table.Style.Display = "inline"' inutile For i = 1 To plage.Rows.Count Set TR = .createelement("TR") For col = 1 To plage.Columns.Count Set cel = plage.Cells(i, col) If Not DICO.exists(cel.MergeArea.Address) Then 'ca c'est mes ancienne version je n'utilise plus de dictionnaires DICO je la remplace par le test de l'existence dans le document
pour la taille de police c'est par exemple

Code:

element.style.fontsize=cells(1,1).font.size &"pt" pour rester en point

ou

Code:

element.style.fontsize=cells(1,1).font.size * ppx &"px"

ppx étant le multiplicateur pour obtenir la dimention de point a pixel

on l'obtient comme ceci par exemple

Code:

With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With

06/11/2017, 12h36
Denis_67

Bonjour Patrick,

Tu peux m'envoyer ta derniere version, je ne la vois pas dans Contribuez. Je l'avais récupérée sur un post où tu avais répondu.
Ou alors c'est juste cette partie que je dois remplacer ?
Merci.

re la derniere methode

re
Bonjour denis
la dernière version emploi une autre méthode plus complète en utilisant le XML de la plage

Code:

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
146
147
148
149
150
151
152
153
Option Explicit
Sub testx()
    Dim doc As Object, plage, xxml, IE
    Set plage = Range("a1:i54")'change ta plage ici c'est tout!!!!!
    Set doc = CreateObject("htmlfile")
    basetable doc, plage, xxml    'creation de la table de base et recuperation du xml correspondant
     doc.body.innerhtml = htmltextecell(xxml, doc)    'ajout du innerhtml et changement des id avec les données du xml
      ' apercu instantané dans internet explorer
    Set IE = CreateObject("internetexplorer.application")
    IE.Visible = True
    IE.navigate "about:blank"
    'IE.document.write html_with_CSStyle2(doc, PLAGE, xxml)
IE.document.write html_with_CSStyle2(doc, plage, xxml)
End Sub
 
Function html_with_CSStyle2(doc, plage, xxml)
 
    Dim docxml As New MSXML2.DOMDocument, Noeuds As MSXML2.IXMLDOMNodeList, SubNoeuds As MSXML2.IXMLDOMNodeList
    Dim balise As IXMLDOMNode, subBalise As IXMLDOMNode, Element As IXMLDOMElement, ElementST As IXMLDOMElement, noeud As IXMLDOMElement
    Dim i#, A#, F#, ppx#, b$, FZ$, ids, TD, TDS, tdi, styles, Attributs, Fonts, StyleB$, Bweight$, BdColor$
    FZ = val((ThisWorkbook.styles("Normal").font.Size) * ppx) & "px"
    xxml = Replace(Replace(Replace(plage.Value(xlRangeValueXMLSpreadsheet), "ss:Data", "Data"), "<Borders>", ""), "</Borders>", "")
    If Not docxml.LoadXML(xxml) Then err.Raise docxml.parseError.ErrorCode, , docxml.parseError.reason
    With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
    Set TDS = doc.getElementsByTagName("TD")
    With docxml
        Set Noeuds = docxml.getElementsByTagName("Style")
        For Each balise In Noeuds
            'Debug.Print Balise.XML
            Set ElementST = balise
            ids = ElementST.getAttribute("ss:ID")
            For tdi = 0 To TDS.Length - 1
                If TDS(tdi).iD = ids Then
                    Set TD = TDS(tdi)
                    If IsDate(TD.innertext) Or IsNumeric(TD.innerhtml) Then TD.Style.textalign = "right"
                    For Each subBalise In balise.ChildNodes
                        Set Element = subBalise
                        Set Attributs = Element.Attributes
                        If Attributs.Length <> 0 Then
                            For A = 0 To Attributs.Length - 1
                                Select Case Attributs(A).BaseName
                                Case "FontName": TD.Style.fontfamily = Attributs(A).Value
                                Case "Size": TD.Style.FontSize = Round(val(Attributs(A).Value)) * ppx
                                Case "Bold": TD.innerhtml = "<B>" & TD.innerhtml & "</B>"
                                Case "Italic": TD.innerhtml = "<i>" & TD.innerhtml & "</i>"
                                Case "StrikeThrough": TD.innerhtml = "<s>" & TD.innerhtml & "</s>"
                                Case "Underline": TD.innerhtml = "<u>" & TD.innerhtml & "</u>"
                                Case "Color"
                                       If Element.tagName = "Font" And Not TD.innerhtml Like "*FONT*" Then TD.Style.Color = Attributs(A).Value
                                    If Element.tagName = "Interior" Then TD.Style.backgroundcolor = Attributs(A).Value
                                Case "Horizontal": TD.Style.textalign = Attributs(A).Value
                                Case "Vertical": TD.Style.verticalalign = Replace(Attributs(A).Value, "Center", "Middle")
                                Case "VerticalAlign":
                                    If Attributs(A).Value = "Superscript" Then TD.innerhtml = "<sup>" & TD.innerhtml & "</sup>"
                                    If Attributs(A).Value = "Subscript" Then TD.innerhtml = "<sub>" & TD.innerhtml & "</sub>"
                                Case "Position":
Debug.Print Element.getAttribute("ss:LineStyle")
                                    StyleB = Replace(Replace(Replace(Replace(Element.getAttribute("ss:LineStyle"), "Continuous", "solid "), "SlantDashDot", "dashed "), "Dash", "dashed "), "Dot", "dotted ")
                                    Bweight = Element.getAttribute("ss:Weight") & "px "
                                    If StyleB = "dotted " Then Bweight = "2px "
                                    If Element.getAttribute("ss:LineStyle") = "DashDot" Then StyleB = "dashed ": Bweight = "3px "
 
                                    If IsNull(Element.getAttribute("ss:Color")) Then BdColor = "#000000" Else BdColor = Element.getAttribute("ss:Color")
                                    Select Case Attributs(A).Value
                                    Case "Top": TD.Style.bordertop = Bweight & StyleB & " " & BdColor
                                    Case "Left": TD.Style.borderleft = Bweight & StyleB & " " & BdColor
                                    Case "Right": TD.Style.borderright = Bweight & StyleB & " " & BdColor
                                    'Case "Bottom": TD.Style.borderbottom = Bweight & StyleB & " " & BdColor
                                    End Select
                                End Select
                            Next
                        End If
                    Next
                    TD.innerhtml = "<FONT>" & TD.innerhtml & " </FONT>"
                    If TD.Children.Length > 0 Then TD.Children(0).Style.MarginLeft = "2px": TD.Children(0).Style.MarginRight = "1px"
                End If
            Next
        Next
    End With
 
    html_with_CSStyle2 = doc.body.innerhtml
 
End Function
 
Function htmltextecell(xxml, doc)
    Dim docxml As New MSXML2.DOMDocument
    Dim Noeuds As MSXML2.IXMLDOMNodeList, SubNoeuds As MSXML2.IXMLDOMNodeList
    Dim balise As IXMLDOMNode, cellule As IXMLDOMElement
    Dim Element As IXMLDOMElement, ElementST As IXMLDOMElement, Fonts
    Dim i#, F#, A#, ppx#, z$, ids$, innerh$, styles, Attributs, TD, Adr
    With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
    With docxml
        xxml = Replace(Replace(Replace(xxml, "ss:Data", "Data"), "<Borders>", ""), "</Borders>", "")
        If Not .LoadXML(xxml) Then err.Raise .parseError.ErrorCode, , .parseError.reason
        Set Noeuds = docxml.getElementsByTagName("Comment")
        For i = 0 To Noeuds.Length - 1
            Adr = Noeuds(i).ChildNodes(0).ChildNodes(0).ChildNodes(0).xml
            Set TD = doc.getelementById(Adr)
            Set cellule = Noeuds(i).ParentNode: If Not IsNull(cellule.getAttribute("ss:StyleID")) Then ids = cellule.getAttribute("ss:StyleID")
            TD.iD = ids: TD.classname = Adr
            Set Element = Noeuds(i).ParentNode.ChildNodes(0)
            If Element.tagName = "Data" Then
                innerh = Split(Noeuds(i).ParentNode.ChildNodes(0).xml, "<Data")(1)
                z = Split(innerh, ">")(0)
                innerh = Replace(Split(Replace(innerh, z & ">", ""), "</Data")(0), "xmlns:html=""http://www.w3.org/TR/REC-html40""", "")
                innerh = Replace(Replace(innerh, "xmlns:x=""urn:schemas-microsoft-com:office:excel""", ""), "html:", "")
                TD.innerhtml = innerh
                If IsDate(Range(Adr)) Then TD.innerhtml = Range(Adr).Text
                Set Fonts = TD.getElementsByTagName("FONT")
                For F = 0 To Fonts.Length - 1
                    If Fonts(F).Size <> "" Then Fonts(F).Style.FontSize = Fonts(F).Size * ppx: Fonts(F).Size = "": Fonts(F).removeattribute ("size")
                Next
 
            End If
        Next
    End With
    htmltextecell = doc.body.innerhtml
End Function
Sub basetable(doc, plage, xxml)
    Dim ppx, TR, TD, Tablo, i#, col#, cel, r, FZ$
    With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
    FZ = val(ThisWorkbook.styles("Normal").font.Size * ppx) & "px"
    With doc
        .body.innerhtml = "<table><TBODY></TBODY></table>"
        With .getElementsByTagName("TABLE")(0):
            .Style.Width = (plage.Width + 3) * ppx: .Style.bordercollapse = "collapse": .cellspacing = 0: .Style.FontSize = FZ
            r = .setattribute("range", Replace(plage.Address, "$", ""))
        End With
        Set Tablo = .getElementsByTagName("TBODY")(0)
        For i = 1 To plage.Rows.Count
            Set TR = .createelement("TR")
            r = TR.setattribute("ligne", plage.Cells(i, 1).ROW)
            Tablo.appendchild (TR)
            For col = 1 To plage.Columns.Count
                Set cel = plage.Cells(i, col)
                If .getelementById(Replace(cel.MergeArea.Address, "$", "")) Is Nothing Then
                    cel.AddComment
                    cel.Comment.Text Text:=Replace(cel.MergeArea.Address, "$", "")
                    Set TD = .createelement("TD")
                    TD.iD = Replace(cel.MergeArea.Address, "$", ""): TD.colspan = Range(TD.iD).Columns.Count: TD.rowspan = Range(TD.iD).Rows.Count
                    r = TD.setattribute("address", TD.iD)
                    TD.Style.Width = cel.MergeArea.Width * ppx: TD.Style.Height = cel.MergeArea.Height * ppx
                    'TD.Style.Border = "1px solid rgb(199,199,199)"
                    TR.appendchild (TD)
                End If
            Next
        Next
    End With
    With plage
        xxml = .Value(xlRangeValueXMLSpreadsheet)
        .ClearComments
    End With
End Sub

08/11/2017, 10h15
Denis_67

Merci Patrick
je vais tester, je suis à J - 6 du démarrage !

La plupart des USF sont envoyés en copie ecran.
Pour l'instant je n'en ai qu'un en copie plage HTML.

Bonne journée
Denis
08/11/2017, 10h21
patricktoulon

re
1 seul !!!!!!!!!

tu deconne alors !! donne moi ce usf

si tu envoie tous les autres en capture écran(image) je ne vois pas pourquoi celui ci ne pourrait pas l'être
08/11/2017, 10h49
Denis_67

Justement dans ce cas ce n'est pas un USF !

C'est une demande de création de spécification avec une centaine de lignes à renseigner par différentes personnes (work flow).
Denis

1 pièce(s) jointe(s)

alors créations sur sheets et export en image ou ma dernière méthode en html

si tu le fait sur sheets
ne t'embêté pas avec le html fait le en image aussi

le rendu est de très bonne qualité
Code:

1 2 3 4 5 6 7 8 9 10 Sub capture() With ActiveSheet Set plage = .Range("a4:C7") plage.CopyPicture xlScreen, xlPicture With .ChartObjects.Add(100, 100, plage.Width, plage.Height) .Chart.Paste: .Chart.Export Filename:=Environ("userprofile") & "\Desktop\" & Replace(plage.Address, ":", "-") & ".jpg", FilterName:="jpg" .Delete End With End With End Sub
test et regarde sur ton bureau
voili voilou

en plus au final tu n'a même plus besoins de traiter les fusions et toutes autre cochonneries c'est une photo tout simplement
demonstration
Pièce jointe 325594

08/11/2017, 11h09
Denis_67

non car dans ce cas, il y a un workflow, les destinatiares comlètent des données et font suivre au suivant.
Mais je prend ton code quand même pour d'autres cas éventuels.
Merci
08/11/2017, 11h18
patricktoulon

re

OK si ton workflow est calibré( tu sais le nombre de ligne et de cellule tu peut le pré formater en html quand tout le monde est passé tu envoie le html

en gros un webbrowser dans le classeur avec un tableau html que les utilisateurs remplissent chacun leur tour
quand ca te revient ou le dernier utilisateur envoie le tableau rempli

et même sans webbroser on peut le pré formater en mémoire a chaque ouverture du classeur dans un htmldocument en mémoire (ultra rapide)

bref des solutions il y a

et pour ca tu a tout ce qu'il te faut maintenant
08/11/2017, 11h21
patricktoulon

re

il y a meme une autre solution je n'y avais plus penser

encore du copie et du paste mais en html cette fois ci
si tu la veux t' a qu'a demander

re encore plus simple

tiens regarde celle la
regarde le beau code html tout fait dans le msgbox

si tu veux voir ce que ca donne debloque le ".visible" et bloque le ".quit "

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub test()
    Set plage = Range("A1:C10")
    plage.Copy
    Set ie = CreateObject("internetexplorer.application")
    With ie
        .navigate "about:blank"
        Do: DoEvents: Loop While .readystate <> 4
       ' .Visible = True
        .document.body.innerhtml = "<div contenteditable=true></div>"
        Set div = .document.getelementsbytagname("DIV")(0)
        div.Focus: .ExecWB 13, 0: codehtml = div.innerhtml
        .Quit
    End With
    Application.CutCopyMode = False
    MsgBox codehtml
End Sub

:ptdr::mouarf:

12/11/2017, 10h30
Denis_67

Bonjour Patrick,

Quelle avalanche de propositions !!!

Ton dernier code sur la copie toute simple du HTML est impeccable !
simple et efficace, des fois à pertir d'une idée on se perd dans la complexité !!

J'ai juste dû sortir de ma plage le bouton pour envoyer le message car forcément l'image du bouton ne suit pas, mais c'est bien comme cela.

Je reviendrai plus tard sur les autres propositions si besoin.
Je dois d'abord cimenter l'application pour son démarrage dans la semaine.

Les utilisateurs ferons sûrement des demandes d'amélioration que j'intégrerai alors dans une nouvelle mouture optimisée.

ENCORE Mille fois merci, tu ne peux pas savoir combien ton aide m'a été précieuse !
Denis
12/11/2017, 10h35
unparia

Citation:

Les utilisateurs ferons sûrement des demandes d'amélioration que j'intégrerai alors dans une nouvelle mouture optimisée.

Tu peux très raisonnablement t'y attendre (et pas uniquement les "utilisateurs" *******) et t'y préparer ...

Pour mémoire (mon message 26)

Citation:

Je dirais un mot de tout cela in fine. Il concernera ce qui est important (et ce n'est pas l'image de l'interface, qui l'est, mais les seules données à communiquer, alerte comprise)
Une image de l'interface ne fait que "noyer". Si le destinataire doit de surcroît l'imprimer (ou même simplement sauvegarder sur disque dur) -->> bonjour les coûts (papier ou mémoire).

Un simple petit tour dans un laboratoire d'analyses biologiques vous fera prendre conscience de l'énorme différence existant entre l'interface utilisée par les laborantins et le document recensant les résultats.

Amitiés

******* : et encore plus si ces images doivent être un jour imprimées pour une raison ou pour l'autre ...
Et même uniquement sauvegardées sur un support.

Voir 40 message(s) de cette discussion en une page