Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement