VBA Word - how to generate HTML file

The following VBA code explains how to generate HTML file:

Option Explicit
 
'declare all variables
Dim objWord
Dim oDoc
Dim objFso
Dim colFiles
Dim curFile
Dim curFileName
Dim folderToScanExists
Dim folderToSaveExists
Dim objFolderToScan
 
'set some of the variables
folderToScanExists = False
folderToSaveExists = False
Const wdSaveFormat = 10 'for Filtered HTML output
 
'**********************************
'change the following to fit your system
Const folderToScan = "C:\Word\documentation\"
Const folderToSave = "C:\Inetpub\wwwroot\word\"
'**********************************
 
'Use FSO to see if the folders to read from
'and write to both exist.
'If they do, then set both flags to TRUE,
'and proceed with the function
Set objFso = CreateObject("Scripting.FileSystemObject")
If objFso.FolderExists(folderToScan) Then
  folderToScanExists = True
Else
  MsgBox "Folder to scan from does not exist!", 48, "File System Error"
End If
If objFso.FolderExists(folderToSave) Then
  folderToSaveExists = True
Else
  MsgBox "Folder to copy to does not exist!", 48, "File System Error"
End If
 
If (folderToScanExists And folderToSaveExists) Then
  'get your folder to scan
  Set objFolderToScan = objFso.GetFolder(folderToScan)
  'put al the files under it in a collection
  Set colFiles = objFolderToScan.Files
  'create an instance of Word
  Set objWord = CreateObject("Word.Application")
  If objWord Is Nothing Then
    MsgBox "Couldn't start Word.", 48, "Application Start Error"
  Else
    'for each file
    For Each curFile in colFiles
      'only if the file is of type DOC
      If (objFso.GetExtensionName(curFile) = "doc") Then
        'get the filename without extension
        curFileName = curFile.Name
        curFileName = Mid(curFileName, 1, InStrRev(curFileName, ".") - 1)
        'open the file inside Word
        objWord.Documents.Open objFso.GetAbsolutePathName(curFile)
        'do all this in the background
        objWord.Visible = False
        'create a new document and save it as Filtered HTML
        Set oDoc = objWord.ActiveDocument
        oDoc.SaveAs folderToSave & curFileName & ".htm", wdSaveFormat
        oDoc.Close
        Set oDoc = Nothing
      End If
    Next
  End If
  'close Word
  objWord.Quit
  'set all objects and collections to nothing
  Set objWord = Nothing
  Set colFiles = Nothing
  Set objFolderToScan = Nothing
End If
 
Set objFso = Nothing

VBA Dir function

VBA Notes: DIR Function

Syntax

DIR([pathname] [, attributes])

Returns the name of a file or directory matching a pattern or attribute (String).

Parameters

• pathname (Optional):
  The full path of a file or directory (String).
• attributes (Optional):
  A vbFileAttribute constant specifying the file attributes (Integer):
• 0 = vbNormal (default)
• 1 = vbReadOnly
• 2 = vbHidden
• 4 = vbSystem
• 8 = vbVolume (Macintosh only)
• 16 = vbDirectory
• 64 = vbAlias (Macintosh only)

Remarks

1. The pathname can include a directory and drive.
2. If the pathname cannot be found, a zero-length string ("") is returned.
3. The attributes parameter can be a constant or a numerical expression.
• If omitted, 0 is used, representing files matching the pathname with no attributes.
4. Wildcard characters:
• * (matches zero or more characters)
• ? (matches any single character)
5. To iterate over all files in a folder, specify an empty string ("") for the pathname.
6. First call to DIR requires a pathname. Subsequent calls can omit it to retrieve additional matching file names.
7. When no more files exist, an empty string is returned.
8. File names are not returned in a particular order. To display them in order, consider storing them in an array and sorting them.
9. The vbAlias and vbVolume attributes are only available on Macintosh.
10. Recursive calls to the DIR function are not allowed.
11. If attributes > 256, it is assumed to be a MacID value.
12. Use DIR$ to return a String data type instead of a Variant/String.
13. The MKDIR function can create new directories.
14. For SharePoint paths, use forward slashes (/) instead of backslashes (\) between subfolders.
15. The equivalent .NET function is Microsoft.VisualBasic.FileSystem.Dir

Simple examples:

Example 1: Locate a specific file

Dir("C:\Windows\test.ini")

Example 2: Find files matching a pattern

Dir("C:\Windows\*.ini")

Example 3: Get subsequent file names

Dir()

Example 4: Using a SharePoint path

Dir("//sharepoint-site/folder/subfolder")

Detailed Example:

'''''''''''''''''''''''''''''''''''''''''''
'   Capture file names in an array        '
'''''''''''''''''''''''''''''''''''''''''''
Option Base 1
Sub Capturefiles()
    Dim sPath As String
    Dim sFile As String
    Dim asFiles() As String
    Dim doc As Document
    sPath = "d:\C"
    ChDrive "d"
    ChDir sPath
    sFile = Dir(sPath & Application.PathSeparator & "*.c?")
    Do While sFile <> ""
        i = i + 1
        ReDim Preserve asFiles(1 To i)
        asFiles(i) = sFile
        sFile = Dir
    Loop
    If i = 0 Then
        MsgBox "No file in the folder"
    End If
    '''''''''''''''''''''''''''''''''''''''''''''
    '  Now process the Captured files in array  '
    '''''''''''''''''''''''''''''''''''''''''''''
        Application.ScreenUpdating = False
    'Now copy the whole Active document and paste in this document
    For i = 1 To UBound(asFiles)
        Set doc = Documents.Open(FileName:=sPath & Application.PathSeparator & asFiles(i))
        doc.Activate
        Selection.TypeParagraph
        Selection.TypeText Text:="Program No." & i
        Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
        Selection.Font.Bold = wdToggle
        Selection.EndKey Unit:=wdLine
        Selection.Font.Bold = True
        Selection.TypeParagraph
        doc.Saved = True
        Selection.HomeKey Unit:=wdStory
        Selection.EndKey Unit:=wdStory, Extend:=wdExtend
        Selection.Copy
        ThisDocument.Select
        Selection.EndKey Unit:=wdStory
        Selection.PasteAndFormat (wdPasteDefault)
        doc.Close
    Next i
        Application.ScreenUpdating = True
End Sub
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '  Now close all open documents if you missed to use close '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Sub CloseAllDocs()
    For Each od In Documents
        od.Activate
        ActiveDocument.Close
    Next od
    End Sub