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_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