VBA Snippets

Close

Public Sub Doc_Close(bSave As Boolean, _
                     Optional sDocName As String = "")
   On Error GoTo ErrorHandler
   If sDocName <> "" Then Documents(sDocName).Activate
   If Documents.Count > 0 Then
      Application.StatusBar = "Closing the file : " & ActiveDocument.Name & " ..."
      ActiveDocument.Close savechanges:=bSave
   Else
      GoTo AnError
   End If
   If gbDEBUG = False Then Exit Sub
ErrorHandler:
   Call Error_Handle("Doc_Close", msMODULENAME, 1, _
        "close the document """ & sDocName & """")
End Sub

Doc_CloseContinue

Public Function Doc_CloseContinue(bSave As Boolean) As Boolean
   On Error GoTo ErrorHandler
   ActiveDocument.Close savechanges:=bSave
   Doc_CloseContinue = True
   Exit Function
ErrorHandler:
   Doc_CloseContinue = False
End Function

DocumentDoesNotContainFieldsInformation

Public Sub DocumentDoesNotContainFieldsInformation()
   If gbEND = True Then Exit Sub
   Call MsgBox( _
        "This document does not contain any Merge Fields.", _
        VBA.VbMsgBoxStyle.vbOKOnly + VBA.VbMsgBoxStyle.vbInformation, _
        gsFORM_TITLE)
End Sub

DocumentIsPasswordProtectedExclamation

Public Sub DocumentIsPasswordProtectedExclamation()
   Call MsgBox( _
        "This document is protected by a password." & _
        vbCrLf & _
        "Password protected files are not supported." & _
        vbCrLf & _
        vbCrLf & _
        "You must remove the password if you want to use this document.", _
        VBA.VbMsgBoxStyle.vbOKOnly + VBA.VbMsgBoxStyle.vbExclamation, _
        gsFORM_TITLE)
End Sub

DocVariable_Add

Adds a custom variable to a document.

Public Sub Doc_VariableAdd(sVariableName As String, _
                           vVariableValue As Variant, _
                           Optional sDocName As String = "")
   On Error GoTo AnError
   If sDocName = "" Then sDocName = ActiveDocument.Name
      Documents(sDocName).Variables.Add Name:=sVariableName, value:=vVariableValue
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Doc_VariableAdd", msMODULENAME, 1, _
        "add the document variable """ & sVariableName & """ " & _
        "and assign it the value """ & CStr(vVariableValue) & """")
End Sub

DocVariable_Delete

Removes a custom variable from the active document.

Public Sub Doc_VariableDelete(sVariableName As String, _
                              Optional sDocName As String = "")
Dim varVariable As Variable
   On Error GoTo AnError
   If sDocName = "" Then sDocName = ActiveDocument.Name
   
   For Each varVariable In Documents(sDocName).Variables
      If StrComp(varVariable.Name, sVariableName, vbTextCompare) = 0 Then
                                                 'compare the letters not the case ??????
         varVariable.Delete
      End If
   Next varVariable

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Doc_VariableDelete", msMODULENAME, 1, _
        "delete the document variable """ & sVariableName & """")
End Sub

DocVariable_Get

Returns the value of a custom variable in the active document.

Public Function Doc_VariableGet(sVariableName As String, _
                                Optional vDefault As Variant, _
                                Optional sDocName As String = "") As Variant
Dim varVariable As Variable
   On Error GoTo AnError
   If sDocName = "" Then sDocName = ActiveDocument.Name
   Doc_VariableGet = vDefault              'set the default if the property is not found
   
   For Each varVariable In Documents(sDocName).Variables
      If StrComp(varVariable.Name, sVariableName, vbTextCompare) = 0 Then
                                                 'compare the letters not the case ?
         Doc_VariableGet = varVariable.value
      End If
   Next varVariable
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Doc_VariableGet", msMODULENAME, 1, _
        "return the current value of the document variable """ & sVariableName & """")
End Function

DocVariable_ListAll

Public Sub Doc_VariablesList()

Dim varVariable As Variable
   
   For Each varVariable In ActiveDocument.Variables
      Debug.Print varVariable.Name & " - " & varVariable.Value
   Next varVariable
   
End Sub

DocVariable_Update

Updates the value of a custom variable in the active document.

Public Sub Doc_VariableUpdate(sVariableName As String, _
                              vNewVariableValue As Variant, _
                              Optional sDocName As String = "")
Dim varVariable As Variable
   On Error GoTo AnError
   If sDocName = "" Then sDocName = ActiveDocument.Name
   
   For Each varVariable In Documents(sDocName).Variables
      If StrComp(varVariable.Name, sVariableName, vbTextCompare) = 0 Then
                                                 'compare the letters not the case ??????
         varVariable.value = vNewVariableValue
      End If
   Next varVariable

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Doc_VariableUpdate", msMODULENAME, 1, _
        "update the document variable """ & sVariableName & """ " & _
        "to """ & CStr(vNewVariableValue) & """")
End Sub

FindAndReplace

Performs a find & replace on the current selection in the active document.

Public Sub Doc_FindAndReplace()
   On Error GoTo AnError
'   Selection.Find.ClearFormatting
'   Selection.Find.Replacement.ClearFormatting
'   With Selection.Find
'           .Text = "{Find Text}"
'           .Replacement.Text = "New Text"
'           .Forward = True
'           .Wrap = wdFindContinue
'           .Format = False
'           .MatchCase = False
'           .MatchWholeWord = False
'           .MatchWildcards = False
'           .MatchSoundsLike = False
'           .MatchAllWordForms = False
'   End With
'
'   Selection.Find.Execute Replace:=wdReplaceAll
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Doc_FindAndReplace", msMODULENAME, 1, _
        "find and replace >>>>>>>>>> copy from Excel")
End Sub

FindChevronDoubleOpen

Public Function Doc_FindChevronDoubleOpen(ByVal oDocument As Word.Document, _
                                          ByVal lStartChar As Long) As Long
Const sPROCNAME As String = "Doc_FindChevronDoubleOpen"
Dim oSearchRange As Word.Range
Dim oOpenChevronRange As Word.Range
Dim lOpenChevronCharPos As Long

   On Error GoTo ErrorHandler
   Set oSearchRange = oDocument.Range(Start:=lStartChar)
   oSearchRange.Find.Text = Chr(60) & Chr(60) '"<<"
   oSearchRange.Find.Execute
   If (oSearchRange.Find.Found = True) Then
      Set oOpenChevronRange = oSearchRange
      lOpenChevronCharPos = oSearchRange.Start

      Doc_FindChevronDoubleOpen = lOpenChevronCharPos
   Else
      Doc_FindChevronDoubleOpen = -1
   End If
   Exit Function

ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Function

IsDisplayed

Public Function Doc_IsDisplayed() As Boolean
On Error GoTo ErrorHandler
   If Application.Documents.Count > 0 Then
      Doc_IsDisplayed = True
      Exit Function
   End If
   Doc_IsDisplayed = False
   Exit Function
ErrorHandler:
   Doc_IsDisplayed = False
End Function

NewDocumentBlank

Public Sub Document_NewDocumentBlank()
Const sPROCNAME As String = "ApplyStyleToParagraph"

Dim oDocument As Word.Document

   On Error GoTo ErrorHandler

   Application.StatusBar = "Creating a new document..."

   Set oDocument = Application.Documents.Add(Template:="", _
                                             NewTemplate:=False, _
                                             DocumentType:=WdNewDocumentType.wdNewBlankDocument, _
                                             Visible:=True)

   Application.StatusBar = ""

   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

OpenAndCheck

Performs all the necessary checks on a document or template before opening it.

Public Function Doc_OpenAndCheck(sFolderPath As String, _
                                 sDocName As String, _
                                 Optional bTemplate As Boolean = False, _
                                 Optional sAdditional As String = "", _
                                 Optional sExtension As String = ".doc", _
                                 Optional bMinimise As Boolean = False, _
                                 Optional bInformUser As Boolean = False) As Boolean
Dim bcontinue As Boolean
   On Error GoTo AnError
   bcontinue = True
   If sDocName = "" Then bcontinue = False
   sFolderPath = Folder_AddLine(sFolderPath)
   sDocName = File_AddExt(sDocName, sExtension)

   If bcontinue = True Then
      bcontinue = Folder_Exists(sFolderPath, bInformUser)
   End If

   If bcontinue = True Then
      bcontinue = File_Exists(sFolderPath, sDocName, , bInformUser)
   End If

   If bcontinue = True Then 
      bcontinue = Not Doc_OpenIsIt(sDocName, bInformUser)
   End If

   If bcontinue = True Then
      bcontinue = Doc_Open(sFolderPath, sDocName, bTemplate, sAdditional, _
                           "", bMinimise, bInformUser)
   End If

   Doc_OpenAndCheck = bcontinue
   If gbDEBUG = False Then Exit Function
AnError:
   If bInformUser = True Then 
      Call Error_Handle("Doc_OpenAndCheck", msMODULENAME, 1, _
           "open the document """ & sDocName & """" & vbCrLf & _
           "from the folder location" & vbCrLf & sFolderPath)
   End If
   Doc_OpenAndCheck = False
End Function

OpenDocument

Public Function Doc_Open(ByVal sFolderPath As String, _
                         ByVal sDocName As String, _
                Optional ByVal bBasedOnTemplate As Boolean = False, _
                Optional ByVal sAdditional As String = "", _
                Optional ByVal sExtension As String = ".doc", _
                Optional ByVal bInformUser As Boolean = False) As Boolean
                         
   On Error GoTo AnError
   Application.StatusBar = "Opening the file: " & _
                           sFolderPath & sDocName & sAdditional & sExtension & " ..."
   If bBasedOnTemplate = True Then
      If sExtension = ".doc" Then sExtension = ".dot"
      Documents.Add Template:=sFolderPath & sDocName & sAdditional & sExtension, _
                    NewTemplate:=False
   Else
      Documents.Open FileName:=sFolderPath & sDocName & sAdditional & sExtension
   End If
   Doc_Open = True
   Application.StatusBar = False
   If gbDEBUG_ERRMSG = False Then Exit Function
AnError:
   Call Error_Handle("Doc_Open", msMODULENAME, _
        "open the word document successfully" & vbCrLf & _
        sFolderPath & sDocName & sAdditional & sExtension)
End Function

OpenIsIt

Determines if a particular document is already open.

Public Function Doc_OpenIsIt(sDocName As String, _
                             Optional bInformUser As Boolean = False) As Boolean
Dim idoccount As Integer
   On Error GoTo AnError
   For idoccount = 1 To Documents.count
      If sDocName = Documents(idoccount).Name Then
         Doc_OpenIsIt = True
         If bInformUser = True Then _
            Call Frm_Inform("", "The File """ & sDocName & """ is already open!")
      Else
         Doc_OpenIsIt = False
      End If
   Next idoccount
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Doc_OpenIsIt", msMODULENAME, 1, _
        "determine if the document called """ & sDocName & """" & vbCrLf & _
        "is already open")
End Function

PropertiesTransfer

Transfers all the properties from one document to a different document.

Public Sub Doc_PropertiesTransfer(sFromDocName As String, _
                                  sToDocName As String)
Dim dpProperty As DocumentProperty
   On Error GoTo AnError
   For Each dpProperty In Documents(sFromDocName).CustomDocumentProperties
      Documents(sToDocName).CustomDocumentProperties.Add Name:=dpProperty.Name, _
               LinkToContent:=False, Type:=msoPropertyTypeString, value:=dpProperty.value

   Next dpProperty
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Doc_PropertiesTransfer", msMODULENAME, 1, _
        "transfer the custom document properties from the document " & sFromDocName & _
        " to the document " & sToDocName)
End Sub

PropertyCustomAdd

Public Function Doc_PropertyCustomAdd(ByVal sPropertyName As String, _
                                      ByVal vPropertyValue As Variant, _
                             Optional ByVal sPropertyType As String = "Text", _
                             Optional ByVal sDocumentName As String = "") As Variant
Const sPROCNAME As String = "Doc_PropertyCustomAdd"
Dim dpProperty As DocumentProperty
Dim lvaluetype As Long
   On Error GoTo AnError
   If sDocumentName = "" Then sDocumentName = ActiveDocument.Name
   lvaluetype = Doc_PropertyDataTypeReturn(vPropertyValue)
   
   Documents(sDocumentName).CustomDocumentProperties.Add Name:=sPropertyName, _
                                                         LinkToContent:=False, _
                                                         Value:=vPropertyValue, _
                                                         Type:=lvaluetype
   If g_bDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(sPROCNAME, msMODULENAME, Err.Number, _
        "add the document property '" & sPropertyName & "' " & _
        "and assign it the value '" & CStr(vPropertyValue) & "'.")
End Function

PropertyCustomExists

Public Function Doc_PropertyCustomExists(ByVal sPropertyName As String, _
                                Optional ByVal sDocumentName As String = "") As Boolean
Const sPROCNAME As String = "Doc_PropertyCustomExists"
Dim dpProperty As DocumentProperty
   On Error GoTo AnError
   If sDocumentName = "" Then sDocumentName = ActiveDocument.Name
   
   Doc_PropertyCustomExists = False
   For Each dpProperty In Documents(sDocumentName).CustomDocumentProperties
      If dpProperty.Name = sPropertyName Then
         Doc_PropertyCustomExists = True
         Exit Function
      End If
   Next dpProperty
   If g_bDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(sPROCNAME, msMODULENAME, Err.Number, _
        "determine if the 'custom' document property '" & sPropertyName & "' exists.")
End Function

PropertyCustomGet

Public Function Doc_PropertyCustomGet(ByVal sPropertyName As String, _
                                      ByVal vDefaultValue As Variant, _
                             Optional ByVal sDocumentName As String = "") As Variant
Dim dpProperty As DocumentProperty
   On Error GoTo AnError
   If sDocumentName = "" Then sDocumentName = ActiveDocument.Name
   
   Doc_PropertyCustomGet = vDefaultValue    'set the default if not found
   For Each dpProperty In Documents(sDocumentName).CustomDocumentProperties
      If dpProperty.Name = sPropertyName Then
         Doc_PropertyCustomGet = dpProperty.Value
      End If
   Next dpProperty
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Doc_PropertyCustomGet", msMODULENAME, 1, _
        "return the 'custom' document property '" & sPropertyName & "'.")
End Function

PropertyCustomModify

Modifies the contents of a custom property in a document.

Public Sub Doc_PropertyCustomModify(ByVal sPropertyName As String, _
                                    ByVal vPropertyValue As Variant, _
                           Optional ByVal sDocumentName As String = "")
Dim dpProperty As DocumentProperty
   On Error GoTo AnError
   If sDocumentName = "" Then sDocumentName = ActiveDocument.Name
   
   For Each dpProperty In Documents(sDocumentName).CustomDocumentProperties
      If dpProperty.Name = sPropertyName Then
         dpProperty.Delete
         Exit For
      End If
   Next dpProperty
   ActiveDocument.CustomDocumentProperties.Add Name:=sPropertyName, _
                 LinkToContent:=False, Type:=msoPropertyTypeString, Value:=vPropertyValue
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Doc_PropertyCustomModify", msMODULENAME, 1, _
        "modify the document property '" & sPropertyName & "' " & _
        "and assign it the value '" & CStr(vPropertyValue) & "'.")
End Sub

PropertyCustomSet

Public Function Doc_PropertyCustomSet(ByVal sPropertyName As String, _
                                      ByVal vNewPropertyValue As Variant, _
                             Optional ByVal sDocumentName As String = "") As Variant
Dim dpProperty As DocumentProperty
   On Error GoTo AnError
   If sDocumentName = "" Then sDocumentName = ActiveDocument.Name
   
   For Each dpProperty In Documents(sDocumentName).CustomDocumentProperties
      If dpProperty.Name = sPropertyName Then
         dpProperty.Value = vNewPropertyValue
      End If
   Next dpProperty
   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Doc_PropertyUpdate", msMODULENAME, 1, _
        "change the 'custom' document property '" & sPropertyName & "' " & _
        "to '" & CStr(vNewPropertyValue) & "'.")
End Function

PropertyDataTypeReturn

Public Function Doc_PropertyDataTypeReturn(ByVal vPropertyValue As Variant) _
                                           As Long
Const sPROCNAME As String = "Doc_PropertyDataTypeReturn"
Dim ltemporary As Long
   On Error GoTo AnError
   Select Case VarType(vPropertyValue)
       Case vbBoolean:             ltemporary = msoPropertyTypeBoolean
       Case vbDate:                ltemporary = msoPropertyTypeDate
       Case vbDouble, vbLong:      ltemporary = msoPropertyTypeFloat
       Case vbSingle, vbCurrency:  ltemporary = msoPropertyTypeFloat
       Case vbInteger:             ltemporary = msoPropertyTypeNumber
       Case vbString:              ltemporary = msoPropertyTypeString
       
      Case Else
         Call MsgBox("Incorrect Document Property Type abbreviation : " & _
                     CStr(vPropertyValue))
   End Select
   Doc_PropertyDataTypeReturn = ltemporary
   If g_bDEBUG = False Then Exit Function
AnError:
   Call Error_Handle(sPROCNAME, msMODULENAME, Err.Number, Err.Description)
End Function

Type

Public Function Doc_Type() As String
   On Error GoTo AnError

   Select Case ActiveDocument.Type
      Case 1: Doc_Type = "Template"
'      Case ??
   End Select

   If gbDEBUG = False Then Exit Function
AnError:
   Call Error_Handle("Doc_Type", msMODULENAME, 1, _
        "")
End Sub

Word_Create

Public Sub Word_Create()
   On Error GoTo AnError                    'called when opening Word
   Set gXLappl = Application
   Set gWDappl = CreateObject("Word.Application")

   gWDappl.Application.Windowstate = 2   'print preview view ??
   gWDappl.Visible = True
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Word_Create", msMODULENAME, 1, _
        "create an instance of Word")
End Sub

Word_DatastreamInsert

Public Sub Word_DatastreamInsert(XLSheet As String, _
                                 WireCode As String, _
                                 BMNumber As Integer)
Dim sSubDirectory As String
   On Error GoTo AnError
   gWDappl.activedocument.bookmarks("BMDatastreamCht" & BMNumber).Select
   gWDappl.Application.Run MacroName:="DeleteNo"
   SubDirectory$ = gXLwrkb.Worksheets(XLSheet).Range("BMDatastreamDir").Value
   gWDappl.Selection.InlineShapes.AddPicture FileName:="" & SubDirectory$ & _
   "\" & WireCode & ".wmf", LinkToFile:=True, SaveWithDocument:=True
    
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Word_DatastreamInsert", msMODULENAME, 1, _
        "insert the Datastream chart from" & vbCrLf & sFolderPath & sFileName)
End Sub

Word_Destroy

Public Sub Word_Destroy(Optional bOpenedNewWord As Boolean = True, _
                        Optional bCreatedNewDocument As Boolean = False)
   On Error GoTo AnError
'   gWDappl.application.quit(wddonotsavechanges, wdsaveoptions)
' if a new document was created
   If bCreatedNewDocument = True Then
      gWDappl.activedocument.Close savechanges:=0
   End If

'was there an instance of word running
   If bOpenedNewWord = True Then
      gWDappl.Application.Quit savechanges:=0
   End If
   Set gWDappl = Nothing
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Word_Destroy", msMODULENAME, 1, _
        "")
End Sub

Word_DocOpen

Public Sub Word_DocOpen(sFolderPath As String, _
                        sFileName As String, _
                        Optional sExtension As String = ".doc", _
                        Optional bAsATemplate As Boolean = False)
Dim serrortext As String
   On Error GoTo AnError
   gWDappl.changeFileOpenDirectory sFolderPath
   If bAsATemplate = False Then
      gWDappl.Documents.Open FileName:=sFileName & sExtension
   Else
      gWDappl.Documents.Add Template:=sFileName & ".dot", NewTemplate:=False
   End If
   If gbDEBUG = False Then Exit Sub
AnError:
   If bAsATemplate = True Then serrortext = vbCrLf & "as a Word template"

   Call Error_Handle("Word_DocOpen", msMODULENAME, 1, _
        "open the Word document & vbCrLf & sFolderPath & sFileName" & serrortext)
End Sub

Word_DocSaveAs

Public Sub Word_DocSaveAs()
   On Error Goto AnError

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Word_DocSaveAs", msMODULENAME, 1, _
        "")
End Sub

Word_Finish

Public Sub Word_Finish()
   On Error GoTo AnError
   Set gXLappl = Nothing
   Set gXLwrkb = Nothing
   Set gWDappl = Nothing
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Word_Finish", msMODULENAME, 1, _
        "close the Word application")
End Sub

Word_MacroRun

Public Sub Word_MacroRun(sMacroName As String)
   On Error GoTo AnError
   gWDappl.Application.Run MacroName:=sMacroName
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Word_MacroRun", msMODULENAME, 1, _
        "")
End Sub

Word_OpenIsIt

Public Function Word_OpenIsIt(Optional bInformUser As Boolean = False) As Boolean
On Error GoTo AnError
   Set gWDappl = GetObject(, "Word.Application")
'   Set gXLappl = Application
   Word_OpenIsIt = True
   If gbDEBUG = False Then Exit Function
AnError:
   Word_OpenIsIt = False
End Function

Zoom

Adjusts the zoom percentage of the active document.

Public Sub Doc_Zoom(iPercent As Integer)
   On Error GoTo AnError
   ActiveWindow.ActivePane.View.Zoom.Percentage = iPercent
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Doc_Zoom", msMODULENAME, 1, _
        "")
End Sub

---

© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top