Customization

Private Sub Document_New()
    ' ----- Initiate variables ------------------------------
    Dim myFile As String
    Dim textline As String
    Dim GraphicsWidth As Long
    Dim posDoc As Integer
    Dim fso, str_tmppath
    Set fso = CreateObject("Scripting.FileSystemObject")
    str_tmppath = Environ("temp")
    myFile = fso.BuildPath(str_tmppath, "reportGenerator.inp")
    ' ----- Read input file with document properties ---------
    Open myFile For Input As #1
    Line Input #1, textline
    Line Input #1, textline
    UserFiles = Mid(textline, 18)
    Line Input #1, textline
    ReportName = HTMLDecode(Mid(textline, 18))
    Line Input #1, textline
    Title = HTMLDecode(Mid(textline, 18))
    Line Input #1, textline
    Subject = HTMLDecode(Mid(textline, 18))
    Line Input #1, textline
    DocumentID = HTMLDecode(Mid(textline, 18))
    Line Input #1, textline
    Revision = HTMLDecode(Mid(textline, 18))
    Line Input #1, textline
    ItemNumber = HTMLDecode(Mid(textline, 18))
    Line Input #1, textline
    LastSaved = Mid(textline, 18)
    Line Input #1, textline
    ProductVersion = Mid(textline, 18)
    Line Input #1, textline
    Author = HTMLDecode(Mid(textline, 18))
    Line Input #1, textline
    Reviewer = HTMLDecode(Mid(textline, 18))
    Line Input #1, textline
    PreparedFor = HTMLDecode(Mid(textline, 18))
    Line Input #1, textline
    TabCaptionTop = Mid(textline, 18)
    Line Input #1, textline
    TabCaptionName = Mid(textline, 18)
    Line Input #1, textline
    TabCaptionStyle = Mid(textline, 18)
    Line Input #1, textline
    FigCaptionName = Mid(textline, 18)
    Line Input #1, textline
    FigCaptionStyle = Mid(textline, 18)
    Line Input #1, textline
    GraphicsWidth = CLng(Mid(textline, 18))
    Line Input #1, textline
    ImageBorder = Mid(textline, 18)
    Close #1
    ' ----- Define html file name --------
    posDoc = InStr(ReportName, ".doc") - 1
    BaseName = Mid(ReportName, 1, posDoc)
    HtmlFile = BaseName + ".html"
    ' ----- Assign built in document properties ---------------------------------------------
    ActiveDocument.BuiltInDocumentProperties(wdPropertyTitle) = Title
    ActiveDocument.BuiltInDocumentProperties(wdPropertySubject) = Subject
    ActiveDocument.BuiltInDocumentProperties(wdPropertyAuthor) = Author
    ' ----- Assign "CustomDocumentProperties" in the template -------------------------------
    ActiveDocument.CustomDocumentProperties("document_id").Value = DocumentID
    ActiveDocument.CustomDocumentProperties("document_revision").Value = Revision
    ActiveDocument.CustomDocumentProperties("document_item_number").Value = ItemNumber
    ActiveDocument.CustomDocumentProperties("project_product_version").Value = ProductVersion
    ActiveDocument.CustomDocumentProperties("project_last_saved").Value = LastSaved
    ActiveDocument.CustomDocumentProperties("document_author").Value = Author
    ActiveDocument.CustomDocumentProperties("document_reviewer").Value = Reviewer
    ActiveDocument.CustomDocumentProperties("document_prepared_for").Value = PreparedFor
    ' ----- Update "Title.png" image path on front page -------------------------------------
    For Each objField In ActiveDocument.Fields
      If Not objField.LinkFormat Is Nothing Then
        If objField.LinkFormat.Type = wdLinkTypePicture Then
            objField.LinkFormat.SourceFullName = UserFiles + "\" + BaseName + "_images\Title.png"
            objField.LinkFormat.Update
        End If
      End If
    Next objField
    '----- Import html report ------------------------------------
    ChangeFileOpenDirectory UserFiles
    Selection.EndKey Unit:=wdStory
    Selection.InsertFile FileName:=HtmlFile, Range:="", _
        ConfirmConversions:=False, Link:=False, Attachment:=False
    ' ----- Import appendix (if existing) ------------------------
    Open myFile For Input As #1
    Do Until EOF(1)
        Line Input #1, textline
        If InStr(1, textline, "Appendix:", vbTextCompare) > 0 Then
            AppendixName = Mid(textline, 11)
            Selection.EndKey Unit:=wdStory
            Selection.InsertFile FileName:=AppendixName, Range:="", _
                ConfirmConversions:=False, Link:=False, Attachment:=False
        End If
    Loop
    Close #1
    ' ----- Find Table captions and apply caption style -----
    foundTab = True
    Do Until foundTab = False
        Set myRange = ActiveDocument.Content
        myRange.Find.Execute FindText:=TabCaptionName, Forward:=True
        foundTab = myRange.Find.Found
        If foundTab = True Then
            myRange.Select
            If TabCaptionTop = "True" Then Selection.Paragraphs(1).KeepWithNext = True
            If TabCaptionStyle <> "None" Then Selection.Paragraphs(1).Style = TabCaptionStyle
            TextToFields Selection.Range
        End If
    Loop
    ' ----- Find Figure captions and apply caption style -----
    foundFig = True
    Do Until foundFig = False
        Set myRange = ActiveDocument.Content
        myRange.Find.Execute FindText:=FigCaptionName, Forward:=True
        foundFig = myRange.Find.Found
        If foundFig = True Then
            myRange.Select
            If FigCaptionStyle <> "None" Then Selection.Paragraphs(1).Style = FigCaptionStyle
            TextToFields Selection.Range
        End If
    Loop
    ' ----- Update Figure width if needed ---------
    With ActiveDocument.Range
        For i = 1 To .InlineShapes.Count
            With .InlineShapes(i)
                If .Width > 10 Then
                    If .Width > GraphicsWidth Then
                        .LockAspectRatio = True
                        .Width = GraphicsWidth
                    End If
                    If i > 1 Then   'Ignore first Title image
                        If ImageBorder = "Yes" Then .Borders.Enable = setShapeBorder
                        .Select
                        Selection.Paragraphs(1).KeepWithNext = True
                    End If
                End If
            End With
        Next i
    End With
    ' ----- Select all text -----------------------
    Selection.WholeStory
    ' ----- Remove background shading (optional) --
    With Selection.Font.Shading
        .Texture = wdTextureNone
        .ForegroundPatternColor = wdColorAutomatic
        .BackgroundPatternColor = wdColorAutomatic
    End With
    ' ----- Convert text to fields (optional) -----
    'CallTextToFields
    ' ----- Update all fields ---------------------
    ActiveDocument.Fields.Update
    ' ----- Save document -------------------------
    Selection.EndOf
    posDocx = InStr(ReportName, ".docx")
    If posDocx > 0 Then
        ActiveDocument.SaveAs2 FileName:=ReportName, FileFormat:=wdFormatXMLDocument
    Else
        ActiveDocument.SaveAs2 FileName:=ReportName, FileFormat:=wdFormatDocument
        Call breakLinks
        ActiveDocument.Save
    End If
End Sub

Sub breakLinks()
    For Each objField In ActiveDocument.Fields
        If Not objField.LinkFormat Is Nothing Then
            objField.LinkFormat.BreakLink
        End If
    Next
    ActiveDocument.UndoClear
End Sub

Sub CallTextToFields()
    Dim rng As Range
    Set rng = Selection.Range
    TextToFields rng
End Sub

Sub TextToFields(rng1 As Range)
    Dim rng As Range
    Dim fld As Field
    Set rng = GetField(rng1)
    Do Until rng Is Nothing
        rng.Characters.First.Delete 'remove the "{"
        rng.Characters.Last.Delete 'and the '}'
        rng.Copy
        Set fld = ActiveDocument.Fields.Add(rng, wdFieldEmpty, rng.Text, False)
        fld.Code.Paste 'VBA bug. The line above corrupts nested fields, so we replace the range
        Set rng = GetField(rng1)
    Loop
End Sub

Function GetField(rng As Range) As Range
    Dim rngStart As Long
    Dim rng1 As Range
    Dim bFound As Boolean
    'looks for a potential field i.e. text bracketed with "{" and "}", but no contained "{"
    Set rng1 = rng.Duplicate
    bFound = True
    Do While bFound
        With rng1.Find
            bFound = False
            .Text = "{"
            .MatchWildcards = False
            If .Execute Then
                bFound = True
                rngStart = rng1.Start
                rng1.Collapse wdCollapseEnd
                rng1.End = rng.End
                .MatchWildcards = True
                .Text = "[\{\}]{1}"
                If .Execute Then
                    If rng1.Characters.First.Text = "}" Then
                        rng1.Start = rngStart
                        Set GetField = rng1.Duplicate
                        Exit Function
                    End If
                End If
                rng1.Start = rngStart + 1
                rng1.End = rng.End
            End If
        End With
    Loop
End Function

Function HTMLDecode(sInput As String) As String
    Dim oHTMLFile As Object
    Set oHTMLFile = CreateObject("HTMLFile")
    oHTMLFile.Body.innerHTML = sInput
    HTMLDecode = oHTMLFile.Body.innerText
End Function