Export document

Option Explicit

Sub BeginExportDocument()
    frmChooseDocument.Show
End Sub

'**
 ' Get value of every instance of 'Heading 1' formatted text within the document
 '
 ' @param Boolean allowMultiple     Whether or not to allow multiple instances of each 'Heading 1'
 ' @retrun Array(String) headings   All 'Heading 1' instances that have been found
 '*
Function GetHeadings(Optional ByVal allowMultiple As Boolean = False) As String()

    Dim blnFound As Boolean     ' Whether or not a 'Heading 1' style has been found
    Dim headings() As String    ' The 'headings' in this documents
    Dim i As Integer            ' Dummy counter for expanding the 'headings' array as necessary
    Dim sanitizedText As String ' The sanitized 'Heading 1' text to add to the 'headings' array

    '** Get the current location of the cursor in the document so that the cursor can be returned there after the 'headings' have been found *'
    Dim currentPosition As Range
    Set currentPosition = Selection.Range

    '** Initilise the 'headings' array to avoid errors '*
    i = 0
    ReDim headings(i)
    headings(i) = ""

    '** Set up the Find conditions for the Find *'
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Heading 1")
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With

    '** Execute the Find and repeat until there are no more matches *'
    blnFound = True
    While blnFound

        With Selection.Find
            .Execute

            '** Check to see if a match has been found... *'
            If .Found = True Then   ' There is a match

                '** Clean the text to ensure that there is no unnecessary whitespace *'
                sanitizedText = Left(Selection.Text, Len(Selection.Text) - 1)

                '** Ensure that the match does not already exist in the 'headings' array (if multiple entries are not allowed) *'
                If _
                (Not allowMultiple And Not InArray(sanitizedText, headings)) Or _
                allowMultiple _
                Then
                    ReDim Preserve headings(i)
                    headings(i) = sanitizedText
                    i = i + 1
                End If

                '** Move to the right of the selection to ensure it is not matched in the next execution of this Find *'
                Selection.MoveRight Unit:=wdCharacter, Count:=1

            Else    ' No match
                blnFound = False
            End If

        End With

    Wend

    '** Return the cursor to it's original position *'
    currentPosition.Select

    '** Return the headings that have been found *'
    GetHeadings = headings

End Function

'**
 ' Handle the selection of a chosen 'Heading 1' section (and it's contents) and it's export to another document
 '
 ' @param required String headingName   The name of the 'Heading 1' section to select
 ' @raturn Boolean result               Whether or not the export process as a whole was successful
 '*
Function StartExportDocument(Optional ByVal headingName As String = "") As Integer

    '** Ensure that a 'headingName' has been passed *'
    If headingName = "" Then Exit Function

    '** Set the result to '0' initially *'
    Dim result As Integer
    result = 0              ' Not successful, but don't display any error

    '** Move the cursor to the start of the document to ensure that the whole of the desired document is selected *'
    Selection.HomeKey Unit:=wdStory

    '** Select the 'Header 1' formatted text of the 'headingName' that has been passed and the content under it and check whether or not the selection is valid *'
    If Functions.SelectSection(headingName) Then  ' It is valid
        If Functions.CopyToNewDocument(headingName) Then
            result = 1  ' Successful
        Else
            result = 2  ' Not successful
        End If
    Else ' It is not valid

        '** Warn the user that an error has occured *'
        Call MsgBox("Sorry, the heading """ & headingName & """ could not be found, so there is nothing selected to export." & vbCrLf & vbCrLf & "Please ensure you choose a valid document to export from the dropdown provided.", vbInformation, "Invalid Selection")

        '** Show the form allowing the user to choose a section again *'
        Call Functions.BeginExportDocument

        result = 3

    End If

    StartExportDocument = result

End Function

'**
 ' Find and select the required 'Heading 1' formatted text and the content under it
 '
 ' @param required String headingName   The 'Heading 1' formatted text to find/select
 '*
Function SelectSection(ByVal headingName As String) As Boolean

    '** Set the result to 'False' initially *'
    Dim result As Boolean
    result = False

    '** Find the 'Header 1' formatted text of the required 'headingName' *'
    With Selection.Find
        .ClearFormatting
        .Style = ActiveDocument.Styles("Heading 1")
        .Text = headingName
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With

    '** Select the 'Header 1' formatted text of the required 'headingName' *'
    Selection.Find.Execute

    '** Check that some 'Header 1' formatted text is selected (check only the first one if multiple paragraphs are selected). *'
    If ActiveDocument.Styles(Selection.Paragraphs(1).Style).ParagraphFormat.OutlineLevel < wdOutlineLevelBodyText Then

        Dim headStyle As Style
        Set headStyle = Selection.Paragraphs(Selection.Paragraphs.Count).Style
        Selection.Expand wdParagraph
        result = True

    Else:

        result = False

    End If

    If result = True Then

        '** Turn off screen updating (so that the screen does not flicker) *'
        Application.ScreenUpdating = False

        '** Loop through the paragraphs following the selection and incorporate them into the selection (as long as they have a higher outline level than the selected heading) *'
        Do While ActiveDocument.Styles(Selection.Paragraphs(Selection.Paragraphs.Count).Next.Style).ParagraphFormat.OutlineLevel > headStyle.ParagraphFormat.OutlineLevel

            Selection.MoveEnd wdParagraph
            If Selection.Paragraphs(Selection.Paragraphs.Count).Next Is Nothing Then Exit Do

        Loop

    End If

    '** Turn screen updating back on *'
    Application.ScreenUpdating = True

    '** Return the result of the check selection *'
    SelectSection = result

End Function

'**
 ' Copy the selected text to a new document
 '
 ' @param required String headingName   The 'Heading 1' formated text section that is being exported (for the document name)
 ' @return Boolean result               Whether or not the export was successful
 '*
Function CopyToNewDocument(ByVal headingName As String) As Boolean

    '** Set the result to 'False' initially *'
    Dim result As Boolean
    result = False

    '** Copy the selection *'
    Selection.Copy

    '** Set the OpenDirectoy location to be that of the folder containing this document *'
    Dim openDirectory As String
    openDirectory = ActiveDocument.Path

    '** Set the path of the new starter template *'
    Dim template As String
    template = openDirectory & "\" & "NewStarterBlankTemplate.dotx"

    '** Ensure that the new starter template exists in the same directory as this document *'

    Dim tempDoc As Document
    If FileExists(template) = True Then

        '** Create a new document from the new starter template to paste the copied text into *'
        Set tempDoc = Documents.Add(template:=template)

    Else

        '** Create a new blank document to paste the copied text into *'
        Set tempDoc = Documents.Add

    End If

    '** Paste the copied text (tempDoc will be selected by default) *'
    Selection.PasteAndFormat (wdUseDestinationStylesRecovery)

    '** Set the name and path of the file to save *'
    Dim fileName As String
    fileName = SetFileName(openDirectory, headingName)

    '** Set the document properties so that they are applied to the PDF document *'
    If Not SetProperties(tempDoc, headingName) Then
        MsgBox "Unable to set 1 or more of the document properties (Export will continue).", vbInformation, "For your information..."
        Debug.Print "Notice: (Functions.CopyToNewDocument) 1 or more of the document properties could not be set." & vbCrLf
    End If

    '** Ensure that a fileName has been selected *'
    If Not fileName = "" Then

        '** Export the document to PDF *'
        ActiveDocument.ExportAsFixedFormat OutputFileName:= _
            fileName, ExportFormat:= _
            wdExportFormatPDF, OpenAfterExport:=True, OptimizeFor:= _
            wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
            item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
            CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
            BitmapMissingFonts:=True, UseISO19005_1:=False

        result = True

    End If

    '** Close the new document *'
    tempDoc.Close False
    Set tempDoc = Nothing

    CopyToNewDocument = result

End Function

'**
 ' Set the filename to save the document as
 '
 ' @param required String openDirectory The directory that the save as dialog should open in
 ' @param required String headingName   The 'Heading 1' section that is being exported
 '
 '*
Function SetFileName(ByVal openDirectory As String, _
                     ByVal headingName As String) As String

    SetFileName = ""

    '** Set up a 'Save As' dialog
    Dim dlgSaveAs As FileDialog
    Set dlgSaveAs = Application.FileDialog(FileDialogType:=msoFileDialogSaveAs)

    ' Show the 'Save As' dialog
    With dlgSaveAs

        .Title = "Exprot to PDF"                                ' Dialog title
        .InitialView = msoFileDialogViewDetails                 ' The 'view' to use in the dialog
        .InitialFileName = openDirectory & "\" & headingName    ' The initial document name
        .FilterIndex = 7                                        ' The initial document type (*.pdf)

        If .Show = -1 Then

            Dim SelectedItem
            For Each SelectedItem In dlgSaveAs.SelectedItems
                SetFileName = SelectedItem
            Next SelectedItem

        End If

    End With

End Function

'**
 ' Check whether or not an item exists within an array
 '
 ' @param required Variant item The item to find
 ' @param required Variant arr  The array to search
 ' @return Boolean              Whether or not 'item' existed in 'arr'
 '*
Function InArray(ByVal item As Variant, _
                 ByVal arr As Variant) As Boolean

    InArray = (UBound(Filter(arr, item)) > -1)

End Function

'**
 ' Check whether or not a file exists
 '
 ' @param required String file  The file to check the existnece of
 ' @return Boolean              Whether or not 'file' exists
 '*
Function FileExists(ByVal file As String) As Boolean

    FileExists = (Dir(file) > "")

End Function

'**
 ' Set the required properties for this temporary document
 '
 ' @param required Document tempDoc     The temporary document to set properties for
 ' @param required String documentName  The name of the temporary document
 ' @return Boolean result               Whether or not setting all properties was successful
 '*
Function SetProperties(ByRef tempDoc As Document, _
                       ByVal documentName As String) As Boolean

    Dim result As Boolean               ' Whether or not all properties have been set successfully
    Dim propertyResult(2) As Boolean    ' The resultes of each individual property set

    '** Set the desired properties *'
    propertyResult(0) = UpdateDocumentProperty(tempDoc, "Title", "New Starter Guide - " & documentName)
    propertyResult(1) = UpdateDocumentProperty(tempDoc, "Subject", "New starter guide")
    propertyResult(2) = UpdateDocumentProperty(tempDoc, "Keywords", "new starters, guide, help")

    '** Check to see if there was an error setting any of the desired properties *'
    Dim i As Integer    ' Dummy for looping
    For i = 0 To UBound(propertyResult)
        If propertyResult(i) = False Then
            result = False
            Exit For
        Else
            result = True
        End If
    Next i

    SetProperties = result

End Function

'**
 ' Update a single property
 '
 ' @param required Document doc         The document to update a property in
 ' @param required String propertyName  The name of the property to update
 ' @param required String propertyValue The value of the property to update
 ' @param MsoDocProperties propertyType The property type (http://msdn.microsoft.com/en-us/library/aa432509%28v=office.12%29.aspx)
 ' @return Boolean result               Whether or not setting this single property was successful
 '*
Function UpdateDocumentProperty(ByRef doc As Document, _
                                ByVal propertyName As String, _
                                ByVal propertyValue As Variant, _
                                Optional ByVal propertyType As Office.MsoDocProperties = 4)

    '** Set the result to 'False' by default '*
    Dim result As Boolean
    result = False

    '** A property to hold whether or not the property used is default or custom *'
    Dim propertyTypeUsed As String

    '** Check to see if the document property already exists *'
    Dim propertyExists As String
    propertyExists = DoesPropertyExist(doc, propertyName)

    '** Add the property to the appropriate property object *'
    If propertyExists = "builtin" Then                                  ' A default property exists, so use that
        doc.BuiltInDocumentProperties(propertyName).value = propertyValue
        propertyTypeUsed = "default"
    ElseIf propertyExists = "custom" Then                               ' A custom property exists, so use that
        doc.CustomDocumentProperties(propertyName).value = propertyValue
        propertyTypeUsed = "custom"
    Else                                                                ' No property exists, so create a custom property
        doc.CustomDocumentProperties.Add _
            name:=propertyName, _
            LinkToContent:=False, _
            Type:=propertyType, _
            value:=propertyValue
        propertyTypeUsed = "custom"
    End If

    '** Check whether or not the value has actually been set *'
    On Error Resume Next
    If propertyTypeUsed = "default" Then
        result = (doc.BuiltInDocumentProperties(propertyName).value = propertyValue)
    ElseIf propertyTypeUsed = "custom" Then
        result = (doc.CustomDocumentProperties(propertyName).value = propertyValue)
    End If
    On Error GoTo 0
    UpdateDocumentProperty = result

End Function

'**
 ' Check to see if a propery exists within a doucment
 '
 ' @param required Document doc The document to check
 ' @param required String name  The name of the property to check
 ' @return String result        In which scope the propery exists ("builtin", "custom" or "")
 '*
Function DoesPropertyExist(ByRef doc As Document, _
                           ByVal name As String) As String

    '** Set result to "" initially *'
    Dim result
    result = ""

    Dim i   ' Dummy for looping

    '** Loop through each built-in property and check if the desired property exists *'
    For i = 1 To doc.BuiltInDocumentProperties.Count
        If doc.BuiltInDocumentProperties(i).name = name Then
            result = "builtin"
        End If
    Next

    '** Loop through each custom property and check if the desired property exists *'
    If result = "" Then
        For i = 1 To doc.CustomDocumentProperties.Count
            If doc.CustomDocumentProperties(i).name = name Then
                result = "custom"
            End If
        Next
    End If

    DoesPropertyExist = result

End Function

'**
 ' Check the result of a document export and output any necessary errors
 '
 ' @param required Integer result   The result to check
 '*
Sub CheckResult(ByVal result As Integer)

    Select Case result

        Case 0
            Debug.Print "Warning: No result was set, so it's likely something went wrong and was handeled but not reported.  It is suggested that you start debugging..." & vbCrLf
        Case 1
            Debug.Print "Notice: Everything worked fine, your New Started document should have been created." & vbCrLf
        Case 2
            Debug.Print "Notice: (Functions.CopyToNewDocument): No 'fileName' was set, probably because the user canceled at this point, so no PDF was created." & vbCrLf
        Case 3
            Debug.Print "Warning: (Functions.StartExportDocument): There is no valid selection to export." & vbCrLf
            Call MsgBox("Sorry, we're unable to find any text related to the New Starter document that you selected.", vbExclamation, "Text not found")

    End Select

End Sub