20 ans !i-structures

i-structures, le projet

Code Visual Basic d’une macro transformant un fichier Word en HTML

Le présent code peut être inséré dans Microsoft Word

Option Explicit
'(c) 2004 Olivier Burdet : autorisation d'utiliser et de modifier ce code pourvu
'                          que cette notice reste présente avec le nouveau code
'                          Merci de vos remarques à olivier.burdet@epfl.ch
Sub toHTML()
Dim i As Integer, sHTML As String, texteBrut As String, leStyle As String
Dim numImages As Integer, tmp As String, nomFichOut As String, nomFichCMD As String
Dim racineNomsImages As String, Titre As String
Titre = ""
With ActiveDocument
   racineNomsImages = Left(.Name, InStrRev(.Name, ".") - 1)
   sHTML = ""
   For i = 1 To .Paragraphs.Count
      leStyle = LCase(.Paragraphs(i).Style)
      tmp = traiterPara(.Paragraphs(i), numImages, racineNomsImages, texteBrut)
      If Len(tmp) > 0 Then
         If leStyle = "titre 1" Then
            If Titre = "" Then Titre = tmp
            tmp = "<h1>" & tmp & "</h1>" & vbCrLf
         ElseIf leStyle = "titre 2" Then
            tmp = " <h2>" & tmp & "</h2>" & vbCrLf
         ElseIf leStyle = "titre 3" Then
            tmp = "<h3>" & tmp & "</h3>" & vbCrLf
         ElseIf leStyle = "equation" Then
            tmp = "<p align=""center"">" & tmp & "</p>" & vbCrLf
         ElseIf leStyle = "html" Then ' conserver le format HTML
            tmp = Replace(Replace(texteBrut, """<", """<"), ">""", ">""") 'un peu brutal...
         Else ' on pourrait ajouter ici d'autres styles à formatter différemment
            tmp = "<p>" & tmp & "</p>" & vbCrLf
         End If
         sHTML = sHTML & tmp & vbCrLf
   
      End If
   Next
End With
sHTML = "<html>" & vbCrLf & "<head>" & vbCrLf & "<title>" & Titre & "</title>" & vbCrLf _
        & "</head>" & vbCrLf & "<body>" & vbCrLf & sHTML
sHTML = sHTML & "</body>" & vbCrLf & "</html>"
nomFichOut = Left(ActiveDocument.FullName, InStrRev(ActiveDocument.FullName, ".")) & "htm"
ecrireFichier sHTML, nomFichOut
nomFichCMD = Left(ActiveDocument.FullName, InStrRev(ActiveDocument.FullName, ".")) & "cmd"
ecrireFichier """" & nomFichOut & """", nomFichCMD
Shell nomFichCMD, vbHide
End Sub

Function traiterPara(lePar As Paragraph, numImages As Integer, racImages As String, _
                     texteBrut As String)
   
Dim i, n As Integer, parRange() As Long, numRange As Long
Dim txtRange As Range, imgRange As Range
Dim nomImage As String
Dim s As String
   numRange = 0
   With lePar
      ReDim parRange(1, numRange)
      parRange(0, numRange) = .Range.Start
      parRange(1, numRange) = .Range.End
   End With
   
   n = lePar.Range.InlineShapes.Count
   For i = 1 To n
      numRange = numRange + 1
      ReDim Preserve parRange(1, numRange)
      With lePar.Range.InlineShapes(i)
         parRange(1, numRange) = parRange(1, numRange - 1)
         parRange(1, numRange - 1) = .Range.Start
         parRange(0, numRange) = .Range.End
      End With
   Next
   s = ""
   For i = 0 To n
      Set txtRange = ActiveDocument.Range(Start:=parRange(0, i), End:=parRange(1, i))
      texteBrut = txtRange.Text
      If Len(texteBrut) > 0 Then
         If Right(texteBrut, 1) = Chr(13) Then
            texteBrut = Left(txtRange.Text, Len(txtRange.Text) - 1)
         End If
      End If
      s = s & texteBrut
      If i < n Then
         numImages = numImages + 1
         ActiveDocument.Range(Start:=parRange(1, i), End:=parRange(0, i + 1)).Select
         nomImage = sauverImage(racImages & Right("0" & numImages, 2))
         s = s & vbCrLf & "" _
             & vbCrLf
      End If
   Next
   If Len(s) > 1 Then
      If Right(s, 2) = vbCrLf Then
         traiterPara = Left(s, Len(s) - 2)
      Else
         traiterPara = s
      End If
   Else
      traiterPara = ""
   End If
End Function

Function sauverImage(nomDesire As String)
Dim nomFichHTML
Dim nom As String, nomRep As String, nomRepSup As String, nomImage As String, ext As String
Dim fs As Object, fol As Object, f As Object
   nomFichHTML = ActiveDocument.Path & "\temp.htm"
   Selection.Copy
   Documents.Add DocumentType:=wdNewBlankDocument
   Selection.Paste
   ActiveDocument.SaveAs FileName:=nomFichHTML, FileFormat:=wdFormatHTML, _
      Password:="", AddToRecentFiles:=False, _
      SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
   nom = ActiveDocument.FullName
   nomRepSup = ActiveDocument.Path
   nomRep = Left(nomFichHTML, InStrRev(nomFichHTML, ".") - 1) _
            & Application.DefaultWebOptions.FolderSuffix
   ActiveWindow.Close
   Set fs = CreateObject("Scripting.FileSystemObject")
   fs.deletefile nom, True
   Set fol = fs.getfolder(nomRep)
   For Each f In fol.Files
      ext = LCase(Mid(f.Name, InStrRev(f.Name, ".") + 1))
      If ext = "gif" Or ext = "jpg" Then
         nomImage = f.Name
      End If
   Next
   nomDesire = nomDesire & LCase(Mid(nomImage, InStrRev(nomImage, ".")))
   fs.copyfile nomRep & "\" & nomImage, nomRepSup & "\" & nomDesire
   fs.deletefolder nomRep
   sauverImage = nomDesire
End Function

Sub ecrireFichier(s As String, nomFich As String)
Const nFich = 1
   Open nomFich For Output As #nFich
   Print #nFich, s
   Close nFich
End Sub