Imprimer le code en couleur [Fait]

**ouskel'n'or** · 26/02/2007, 17h52

1 - Coller son code sur le forum dans une nouvelle discussion
Pour ceux qui ont de mauvais yeux
1 bis - passer le code en taille 3 ou 4...
2 - Prévisualiser le message
3 - Sélectionner le code
4 - Imprimer "Selection"
5 - Supprimer la discussion...

Et en prime : Le titre du forum en entête et l'URL en bas... Mais avec le code en couleur !

**cafeine** · 26/02/2007, 18h29

Hello,

c'est une possibilité, mais tu peux aussi, utiliser le tuto sur les RegExp et la fonction d'export de module.
voici un patch pour pouvoir l'imprimer dans l'explorateur web (en couleur).

C'est du Access, mais ça peut facilement s'adapter à du VBA.

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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
Option Explicit
 
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 
Function xPortCode(ByVal modName As String, ByVal sizeFont As Integer, _
                   Optional ByVal OpenIt As Boolean = False, _
                   Optional ByVal PrintIt As Boolean = False)
 
    Dim i As Long
    Dim t0 As Single, t1 As Single
    Dim Fic As Integer
    Dim strBuff As String
    Dim reg As VBScript_RegExp_55.RegExp
    Dim KeyWords() As String, KeyWordsList As String
    Dim Types() As String, TypesList As String
    Dim APIarg As String
 
    t0 = Timer
 
    Set reg = New VBScript_RegExp_55.RegExp
    Fic = FreeFile()
 
    Reset
 
    ' ouverture du fichier en écriture
    Open "C:\temp\export " & modName & " (" & Format(Now, "yy-mm-dd") & ").html" For Output As #Fic
 
    ' écriture des en-têtes HTML et style
    Print #Fic, "<HTML>"
    Print #Fic, "<HEAD><TITLE>Export au format HTML du module : " & modName & "</TITLE>"
    Print #Fic, "<meta http-equiv=""Content-Type"" content=""text/html; charset=ISO-8859-1"" />"
    Print #Fic, "<style type='Text/css'>"
    Print #Fic, "<!--"
    Print #Fic, "BODY {"
    Print #Fic, "margin-top:0; margin-left:10; margin-right:0;"
    Print #Fic, "font-family: Lucida Console, Tahoma, Verdana, Arial, Helvetica, sans-serif;"
    Print #Fic, "font-size: " & sizeFont & "px;" ' la variable argument sizeFont passe dans la définition du style
    Print #Fic, "}"
    Print #Fic, ".commentaire {"
    Print #Fic, "color: #669933;"
    Print #Fic, "}"
    Print #Fic, ".chaine {"
    Print #Fic, "color: #993399;"
    Print #Fic, "}"
    Print #Fic, ".key {"
    Print #Fic, "color: #0033BB;"
    Print #Fic, "}"
    Print #Fic, ".type {"
    Print #Fic, "font-weight: bold;"
    Print #Fic, "color: #3366CC;"
    Print #Fic, "}"
    Print #Fic, "-->"
    Print #Fic, "</style>"
    Print #Fic, "</HEAD>"
    Print #Fic, "<BODY>"
 
 
    ' ouverture du module
    DoCmd.OpenModule modName
 
    ' récupération du texte du module
    strBuff = Application.Modules(modName).Lines(1, Application.Modules(modName).CountOfLines)
 
    ' empêcher les ouvertures de tag HTML
    strBuff = Replace(strBuff, "<", "&lt;")
 
    ' les retours chariot
    reg.Pattern = "(\n)"
    reg.Global = True
    reg.IgnoreCase = True
    strBuff = reg.Replace(strBuff, "$1<br />")
 
 
    ' 1- les mots-clé
    KeyWordsList = "AddressOf©Alias©And©As©ByRef©ByVal©Call©Case©Close©CBool©CByte©CCur©" & _
            "CDate©CDec©CDbl©CInt©CLng©CSng©CStr©CVar©Const©Compare©Database©Declare©Debug©Default©" & _
            "Dim©Do©Each©Else©ElseIf©End©Enum©Erase©Error©Explicit©Event©Exit©False©For©" & _
            "Friend©Function©Get©GoTo©Handles©If©Implements©Imports©In©Inherits©" & _
            "Interface©Is©Let©Lib©Like©Loop©Me©Mod©New©Next©Not©Nothing©" & _
            "On©Open©Option©Optional©Or©ParamArray©Preserve©Print©Private©Property©Protected©" & _
            "Public©RaiseEvent©ReadOnly©Redim©REM©Resume©Return©Select©Set©Shared©Static©" & _
            "Step©Stop©Sub©Then© To ©True©Type©TypeOf ©Until©UBound©When©Wend©While©With©WithEvents©WriteOnly©Xor"
 
    KeyWords = Split(KeyWordsList, "©")
    For i = 0 To UBound(KeyWords)
        reg.Pattern = "(\W|^)(" & KeyWords(i) & ")(\W|$)"
        reg.Multiline = False
        reg.Global = True
        reg.IgnoreCase = True
        strBuff = reg.Replace(strBuff, "$1<span class=key>$2</span>$3")
    Next i
 
    ' 2- les commentaires
    '  les REM
    reg.Pattern = "(\s)(rem .*)"
    reg.Multiline = False
    reg.Global = True
    reg.IgnoreCase = True
    strBuff = reg.Replace(strBuff, "$1<span class=commentaire>$2</span>")
 
    '  les apostrophes (')
    reg.Pattern = "(\n)(([^\x22\n]*\x22[^\x22\n]*\x22)*)([^\x22\n']*)('.*)"
    reg.Multiline = False
    reg.Global = True
    reg.IgnoreCase = True
    strBuff = reg.Replace(strBuff, "$1$2$4<span class=commentaire>$5</span>")
 
    ' 3- les types
    TypesList = "Boolean©Byte©Date©Double©Integer©Long©Object©Short©Single©String©Unicode©Variant"
    Types = Split(TypesList, "©")
    For i = 0 To UBound(Types)
        reg.Pattern = "(\W|^)(" & Types(i) & ")(\W|$)"
        reg.Multiline = False
        reg.Global = True
        reg.IgnoreCase = True
        strBuff = reg.Replace(strBuff, "$1<span class=type>$2</span>$3")
    Next i
 
    ' 4- les chaines
    reg.Pattern = "(\x22[^\x22\n]*\x22)"
    reg.Multiline = False
    reg.Global = True
    reg.IgnoreCase = True
    strBuff = reg.Replace(strBuff, "<span class=chaine>$1</span>")
 
    ' Highlight dans un Highlight
    reg.Pattern = "(<span class=\w{6,11}>)(.*)(<span class=\w{3,11}>)(.*)(</span>)(.*</span>)"
    reg.Multiline = False
    reg.Global = True
    reg.IgnoreCase = True
    Do While reg.Test(strBuff)
        strBuff = reg.Replace(strBuff, "$1$2$4$6")
    Loop
 
    ' les espaces
    strBuff = Replace(strBuff, "  ", "  ")
 
    ' écriture de la chaîne dans le fichier
    Print #Fic, strBuff
 
    ' fermeture du module
    DoCmd.Close acModule, modName
 
    Print #Fic, "</BODY>"
    Print #Fic, "</HTML>"
 
    ' libération des objets mémoire
    Reset
    Set reg = Nothing
 
    'Ouverture du fichier HTML
    ' si un Hwnd de formulaire est passé en argument ...
    If OpenIt Then
        APIArg = Iif(PrintIt = True, "print", "open")
        ShellExecute 0, APIArg, "C:\Temp\export " & modName & " (" & Format(Now, "yy-mm-dd") & ").html", "", CurrentProject.Path, 1
    End If
 
    t1 = Timer
 
    Debug.Print "Job done @ " & Format(t1 - t0, "0.000") & " s"
 
End Function

Edit : au début je passais par Word, mais avec ShellExecute c'est inutile.

**ouskel'n'or** · 26/02/2007, 20h08

Tout de suite la grosse artillerie...

Ma solution a au moins l'avantage d'obliger les amateurs à venir sur le forum et en outre, celui d'avoir son URL en pied de page et aussi de n'avoir pas à chercher où ils ont placé cette satanée macro
1 + 1 + 1 = 4 => Cinq raisons de venir sur le forum

**cafeine** · 26/02/2007, 20h23

Bah la fonction était déjà faite, ne restait plus qu'à mettre un "print" dans le ShellExecute :p

**SilkyRoad** · 26/02/2007, 21h03

bonsoir à vous deux

Ci joint adaptation pour Excel ... ;o)
Je suis passé par Word pour l'impression car je n'arrivais pas à faire fonctionner ShellExecute .

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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
Option Explicit
 
Sub lancementProcedure()
    'Le classeur spécifié doit être ouvert
    recupContenuVBE Workbooks("NomClasseur.xls"), "Module1"
 
    'recupContenuVBE Workbooks("NomClasseur.xls"), "Feuil1"
    'recupContenuVBE Workbooks("NomClasseur.xls"), "ThisWorkbook"
End Sub
 
 
 
Function recupContenuVBE(ByVal Wb As Workbook, Optional nomModule As String)
    Dim oModule As Object
    Dim Resultat As String
 
    Set oModule = Wb.VBProject.VBComponents(nomModule).CodeModule
    Resultat = oModule.Lines(1, oModule.CountOfLines)
 
    xPortCode Resultat, 14, Wb.Name, nomModule
End Function
 
 
 
Function xPortCode(ByVal strBuff As String, ByVal sizeFont As Integer, _
        ByVal Titre As String, ByVal nomModule As String)
 
    '
    'Source: http://cafeine.developpez.com/access/tutoriel/regexp/
    '
 
    Dim i As Long
    Dim Fic As Integer
    Dim reg As VBScript_RegExp_55.RegExp
    Dim KeyWords() As String, KeyWordsList As String
    Dim Types() As String, TypesList As String
    Dim APIArg As String
    Dim appWrd As Object, docWord As Object
 
 
    Set reg = New VBScript_RegExp_55.RegExp
    Fic = 1
 
    ' ouverture du fichier en écriture
    Open "C:\" & nomModule & " (" & Format(Now, "yy-mm-dd") & ").html" For Output As #Fic
 
    ' écriture des en-têtes HTML et style
    Print #Fic, "<HTML>"
    Print #Fic, "<HEAD><TITLE>Export au format HTML " & Titre & " - " & nomModule; "</TITLE>"
    Print #Fic, "<meta http-equiv=""Content-Type"" content=""text/html; charset=ISO-8859-1"" />"
    Print #Fic, "<style type='Text/css'>"
    Print #Fic, "<!--"
    Print #Fic, "BODY {"
    Print #Fic, "margin-top:0; margin-left:10; margin-right:0;"
    Print #Fic, "font-family: Arial;"
    'la variable argument sizeFont passe dans la définition du style
    Print #Fic, "font-size: " & sizeFont & "px;"
    Print #Fic, "}"
    Print #Fic, ".commentaire {"
    Print #Fic, "color: #669933;"
    Print #Fic, "}"
    Print #Fic, ".chaine {"
    Print #Fic, "color: #993399;"
    Print #Fic, "}"
    Print #Fic, ".key {"
    Print #Fic, "color: #0033BB;"
    Print #Fic, "}"
    Print #Fic, ".type {"
    Print #Fic, "font-weight: bold;"
    Print #Fic, "color: #3366CC;"
    Print #Fic, "}"
 
    Print #Fic, ".titre {"
    Print #Fic, "font-weight: bold;"
    Print #Fic, "text-decoration: underline;"
    '
    Print #Fic, "font-family: Arial;"
    Print #Fic, "color: #000066;"
    Print #Fic, "font-size: 14px;"
    Print #Fic, "}"
 
    Print #Fic, "-->"
    Print #Fic, "</style>"
    Print #Fic, "</HEAD>"
    Print #Fic, "<BODY>"
 
 
    'empêcher les ouvertures de tag HTML
    strBuff = Replace(strBuff, "<", "&lt;")
 
    ' les retours chariot
    reg.Pattern = "(\n)"
    reg.Global = True
    reg.IgnoreCase = True
    strBuff = reg.Replace(strBuff, "$1<br />")
 
 
    ' 1- les mots-clé
    KeyWordsList = "AddressOf©Alias©And©As©ByRef©ByVal©Call©Case©Close©CBool©CByte©CCur©" & _
            "CDate©CDec©CDbl©CInt©CLng©CSng©CStr©CVar©Const©Compare©Database©Declare©Debug©Default©" & _
            "Dim©Do©Each©Else©ElseIf©End©Enum©Erase©Error©Explicit©Event©Exit©False©For©" & _
            "Friend©Function©Get©GoTo©Handles©If©Implements©Imports©In©Inherits©" & _
            "Interface©Is©Let©Lib©Like©Loop©Me©Mod©New©Next©Not©Nothing©" & _
            "On©Open©Option©Optional©Or©ParamArray©Preserve©Print©Private©Property©Protected©" & _
            "Public©RaiseEvent©ReadOnly©Redim©REM©Resume©Return©Select©Set©Shared©Static©" & _
            "Step©Stop©Sub©Then© To ©True©Type©TypeOf ©Until©UBound©When©Wend©While©With©WithEvents©WriteOnly©Xor"
 
    KeyWords = Split(KeyWordsList, "©")
    For i = 0 To UBound(KeyWords)
        reg.Pattern = "(\W|^)(" & KeyWords(i) & ")(\W|$)"
        reg.MultiLine = False
        reg.Global = True
        reg.IgnoreCase = True
        strBuff = reg.Replace(strBuff, "$1<span class=key>$2</span>$3")
    Next i
 
    ' 2- les commentaires
    '  les REM
    reg.Pattern = "(\s)(rem .*)"
    reg.MultiLine = False
    reg.Global = True
    reg.IgnoreCase = True
    strBuff = reg.Replace(strBuff, "$1<span class=commentaire>$2</span>")
 
    '  les apostrophes (')
    reg.Pattern = "(\n)(([^\x22\n]*\x22[^\x22\n]*\x22)*)([^\x22\n']*)('.*)"
    reg.MultiLine = False
    reg.Global = True
    reg.IgnoreCase = True
    strBuff = reg.Replace(strBuff, "$1$2$4<span class=commentaire>$5</span>")
 
    ' 3- les types
    TypesList = "Boolean©Byte©Date©Double©Integer©Long©Object©Short©Single©String©Unicode©Variant"
    Types = Split(TypesList, "©")
    For i = 0 To UBound(Types)
        reg.Pattern = "(\W|^)(" & Types(i) & ")(\W|$)"
        reg.MultiLine = False
        reg.Global = True
        reg.IgnoreCase = True
        strBuff = reg.Replace(strBuff, "$1<span class=type>$2</span>$3")
    Next i
 
    ' 4- les chaines
    reg.Pattern = "(\x22[^\x22\n]*\x22)"
    reg.MultiLine = False
    reg.Global = True
    reg.IgnoreCase = True
    strBuff = reg.Replace(strBuff, "<span class=chaine>$1</span>")
 
    ' Highlight dans un Highlight
    reg.Pattern = "(<span class=\w{6,11}>)(.*)(<span class=\w{3,11}>)(.*)(</span>)(.*</span>)"
    reg.MultiLine = False
    reg.Global = True
    reg.IgnoreCase = True
    Do While reg.Test(strBuff)
        strBuff = reg.Replace(strBuff, "$1$2$4$6")
    Loop
 
    ' les espaces
    strBuff = Replace(strBuff, "  ", "  ")
 
    ' écriture de la chaîne dans le fichier
    Print #Fic, strBuff
    Print #Fic, "</BODY>"
    Print #Fic, "</HTML>"
 
    ' libération des objets mémoire
    Reset
    Set reg = Nothing
 
    Set appWrd = CreateObject("Word.Application")
    'Indiquez False pour masquer Word pendant l'impression
    appWrd.Visible = True
    Set docWord = appWrd.Documents.Open("C:\" & nomModule & _
        " (" & Format(Now, "yy-mm-dd") & ").html", False)
    docWord.PrintOut
 
    docWord.Close
    appWrd.Quit
    Set docWord = Nothing
    Set appWrd = Nothing
End Function