Private Sub BtRegHtmlFile_Click()
Dim Fichier$, X&
If Trim(TextBox2.Value) = "" Then MsgBox "Aucun code à enregistrer , veuillez d'abords indenter dans l'interface": Exit Sub
'Debug.Print Cod
Fichier = Application.GetSaveAsFilename("code vba _" & modunam.Caption & "Color.html", filefilter:="image Files (*.html), *.html", Title:="Enregistrement du fichier au format html")
If Fichier = "Faux" Then Exit Sub
X = FreeFile
Open Fichier For Output As #X: Print #X, codvbToHtml: Close #X
Frame1.Left = Me.InsideWidth + 10
MsgBox "Un fichier html a été créé Dans" & vbCrLf & Fichier
End Sub
Function codvbToHtml()
Dim cod, expr, tblexp, i&, Fichier$, X&, elem, ps, comm, Color1$, Color2
Color1 = "#2980b9" 'couleur des expressions
Color2 = "green" 'couleurs des commentaires
cod = TextBox2.Value
'les insertion des balise class blue doivent se faire dans un ordre precis
' en effet certaines composées peuvent contenir une une autre non composée
'expression composées
expr = "Private Sub,Public Sub,Private Function,Public Function,End Sub,End If,End With,End Type,End Enum,End property,Select Case,End Select" & _
",Exit Sub,Do While,Do Until,For Each,Exit For,#If,#Else,#End If,Debug.Print, TypeOf " & _
",Private ,Sub ,,Function , Function, Sub,End Exit ,On Error " & _
",Option Compare text,Option Explicit"
'expression simples
expr = expr & "Do ,Until ,While ,With,For ,If , If ,Else, Next, Next,Case ,.Select ,Not , And , Or , Xor ,Const ,Constante ,Const " & _
",Loop ,Wend, As ,Set ,Call , To ,Resume,Err.Clear,then,Exit , Object, Long, Double, Integer, Boolean,Goto 0,Goto,GoSub" & _
",ElseIf,Dim , Is ,False,True, Me ,Me., Each ,Optional ,ByRef ,ByVal ,Nothing,CDbl,Clng,Cdec, In ,ReDim, Preserve," & _
",Cdate,Print ,Open ,.Close,Output,Property,Declare ,PtrSafe,Type,Ubound,Lbound,Resume," & _
vbCrLf & "Next"
tblexp = Split(expr, ",")
cod = Split(cod, vbCrLf)
'on met les commentaires et les lignes commentaire
For i = 0 To UBound(cod)
If InStr(1, cod(i), " '") > 0 Then
cod(i) = Replace(cod(i) & " ", " '", "<font class=""comm"" color=""" & Color2 & """>" & " '") & "</font>"
End If
If Left(Trim(cod(i)), 1) = "'" Then cod(i) = "<font class=""comm"" color=""" & Color2 & """>" & cod(i) & "</font>"
Next
cod = Join(cod, vbCrLf)
'on fait un replace global des expressions et plus ligne par ligne
For i = 0 To UBound(tblexp)
cod = Replace(cod, tblexp(i), "<font class=""blue"" color=""" & Color1 & """><B>" & tblexp(i) & "</B></font>")
Next
cod = Replace(cod, " ", " ")
cod = Replace(cod, "<font ", "<font ")
cod = Split(cod, vbCrLf)
'on met un espace dans les lignes vides sinon elle n'aparaissent pas (margin 0 des p)
For i = 1 To UBound(cod)
If cod(i) = "" Then cod(i) = " "
Next
'on pet les lignes dans des balises "P" in one shot
cod = "<p style='margin:0;color:black;'>" & Join(cod, "</p>" & vbCrLf & "<p style=""margin:0;color:black;"">") & "</p>"
With CreateObject("htmlfile")
.body.innerhtml = cod
Dim par
'maintenant comme on a replacé les expression il se peut que certaines soit dans des commentaires
'alors on nettoie les commentaires
For Each elem In .body.all
On Error Resume Next
If elem.classname = "blue" Then If elem.parentelement.classname = "comm" Then elem.outerhtml = elem.innertext
Err.Clear
Next
codvbToHtml = .body.innerhtml
End With
End Function