Word VBA

DocumentBeforePrint()

Unlike Excel, in Word automatically running a macro before a document is printed requires three pieces of code, located in three different places.

ThisDocument.cls

Private Sub Document_Open()Register_Event_HandlerEnd Sub

Reg_Event_Handler.bas

Dim x As New EventClassModuleSub Register_Event_Handler()Set x.wordApp = Word.ApplicationEnd Sub

EventClassModule.cls

Public WithEvents wordApp As Word.ApplicationPrivate Sub wordApp_DocumentBeforePrint(ByVal Doc As Document, Cancel As Boolean)
'INSERT YOUR CODE HERE'This code runs before the document is printed.MsgBox "Hello World!"
End Sub

WordTools, Random VBA Snippets

'Nolan Manteufel'July 2020
'Used to access Content ControlsPrivate Const customer As String = "customer"Private Const contact As String = "contact"Private Const address As String = "address"Private Const datereceived As String = "dateReceived"Private Const device As String = "device"Private Const complaint As String = "complaint"Private Const caption As String = "caption"Private Const followup As String = "followup"Private Const codes As String = "codes"Private Const stamp As String = "stamp"Private Const datetimestamp As String = "datetimeStamp"
Private Const PLACEHOLDER_TEXT As String = "N/A"
Private Const DATA_ARRAY_WIDTH = 2Private Const DATA_ARRAY_LENGTH = 17
'Module level variablesDim myDoc As DocumentDim lockState As BooleanDim cc As ContentControlDim CCs As ContentControlsDim ccIndex As LongDim FFs As FormFieldsDim ff As FormField
Sub enable_Application()
'Reset button enablesActiveDocument.saveButton.Enabled = TrueActiveDocument.saveAndCloseButton.Enabled = TrueActiveDocument.closeWithoutSavingButton.Enabled = TrueActiveDocument.deleteButton.Enabled = True
'Enable screen updatingApplication.ScreenUpdating = TrueEnd Sub
Sub move_CC_Text_to_Table_In_New_Document()
Set myDoc = ActiveDocumentSet CCs = myDoc.ContentControls
Dim dataArray(DATA_ARRAY_WIDTH, DATA_ARRAY_LENGTH) As StringccIndex = 0
'Fill data arrayFor Each cc In CCs dataArray(0, ccIndex) = ccIndex dataArray(1, ccIndex) = cc.Tag dataArray(2, ccIndex) = cc.Range.Text ccIndex = ccIndex + 1Next cc
'Create new documentDim newDoc As DocumentSet newDoc = Documents.Add
'Insert tableDim newTable As TableSet newTable = newDoc.Tables.Add(Range:=Selection.Range, _NumRows:=DATA_ARRAY_LENGTH + 1, _NumColumns:=DATA_ARRAY_WIDTH + 1)
Dim colIndex As IntegerDim rowIndex As Integer
'Populate table with data arrayWith newTable For rowIndex = 0 To DATA_ARRAY_LENGTH For colIndex = 0 To DATA_ARRAY_WIDTH .Cell(rowIndex + 1, colIndex + 1).Range.InsertAfter dataArray(colIndex, rowIndex) Next colIndex Next rowIndex .Columns.AutoFitEnd WithEnd Sub

Sub set_CC_Text_Per_Tag_Index()Set myDoc = ActiveDocument
myDoc.SelectContentControlsByTag(customer)(1).Range.Text = "1"myDoc.SelectContentControlsByTag(customer)(2).Range.Text = "2"myDoc.SelectContentControlsByTag(customer)(3).Range.Text = "3"
myDoc.SelectContentControlsByTag(contact)(1).Range.Text = "1"myDoc.SelectContentControlsByTag(contact)(2).Range.Text = "2"myDoc.SelectContentControlsByTag(contact)(3).Range.Text = "3"myDoc.SelectContentControlsByTag(contact)(4).Range.Text = "4"
myDoc.SelectContentControlsByTag(address)(1).Range.Text = "1"myDoc.SelectContentControlsByTag(address)(2).Range.Text = "2"myDoc.SelectContentControlsByTag(address)(3).Range.Text = "3"myDoc.SelectContentControlsByTag(address)(4).Range.Text = "4"myDoc.SelectContentControlsByTag(address)(5).Range.Text = "5"
myDoc.SelectContentControlsByTag(device)(1).Range.Text = "1"myDoc.SelectContentControlsByTag(device)(2).Range.Text = "2"
myDoc.SelectContentControlsByTag(caption)(1).Range.Text = "1"myDoc.SelectContentControlsByTag(caption)(2).Range.Text = "2"myDoc.SelectContentControlsByTag(caption)(3).Range.Text = "3"myDoc.SelectContentControlsByTag(caption)(4).Range.Text = "4"
myDoc.SelectContentControlsByTag(codes)(1).Range.Text = "1"myDoc.SelectContentControlsByTag(codes)(2).Range.Text = "2"myDoc.SelectContentControlsByTag(codes)(3).Range.Text = "3"
End Sub
Sub clear_CC_Title()For Each cc In ActiveDocument.ContentControls cc.Title = ""Next ccEnd Sub
Sub clear_CC_Tag()For Each cc In ActiveDocument.ContentControls cc.Tag = ""Next ccEnd Sub

Sub set_CC_Text_Per_CC_Order()ccIndex = 0
For Each cc In ActiveDocument.ContentControls ccIndex = ccIndex + 1 If (cc.Type = wdContentControlText) Then lockState = cc.LockContents cc.LockContents = False cc.Range.Text = "CC Index/Order: " & ccIndex cc.LockContents = lockState End IfNext ccEnd Sub
Sub set_CC_Text_Per_CC_Index()Set CCs = ActiveDocument.ContentControls
For ccIndex = 1 To CCs.Count Set cc = CCs(ccIndex) If (cc.Type = wdContentControlText) Then cc.LockContents = False cc.Range.Text = "CC Index: " & ccIndex End IfNextEnd Sub

Sub set_CC_Placeholder_AND_Clear_Text()Set CCs = ActiveDocument.ContentControls
For Each cc In myDoc.ContentControls ccIndex = ccIndex + 1 If (cc.Type = wdContentControlText) Then lockState = cc.LockContents cc.LockContents = False cc.SetPlaceholderText Text:="Click here to enter text." cc.Range.Text = "" cc.LockContents = lockState End IfNext ccEnd Sub
Sub clear_CC_Text()Set CCs = ActiveDocument.ContentControls
For Each cc In myDoc.ContentControls ccIndex = ccIndex + 1 If (cc.Type = wdContentControlText) Then lockState = cc.LockContents cc.LockContents = False cc.Range.Text = "" cc.LockContents = lockState End IfNext ccEnd Sub
Sub directory()MsgBox (ActiveDocument.Path)End Sub
Sub filename()MsgBox (ActiveDocument.name)End Sub
Sub fullfilename()MsgBox (ActiveDocument.FullName)End Sub
Sub resetForm()Set FFs = ActiveDocument.FormFields
'Reset the form to default valuesFor Each ff In FFsff.result = ff.TextInput.DefaultNext
MsgBox ("Congratulations, your form has been reset to default values.")End Sub
Sub clearForm()Set FFs = ActiveDocument.FormFields
'Clear the formFor Each ff In FFsff.result = ClearNext
MsgBox ("Congratulations, your form has been cleared.")End Sub
Sub CC_COUNT()MsgBox (ActiveDocument.ContentControls.Count)End Sub
Sub DOC_COUNT()MsgBox Application.Documents.CountEnd Sub
'If (Application.Documents.Count = 0) Then'ThisApplication.Quit'End If
Sub END_APP()Application.QuitEnd Sub
Sub END_EXCEL_APP()Excel.Application.QuitEnd Sub
Sub deleteDoc()Kill "Y:\ENG - Engineering Files\860\113 EKF VBA\996 LocalBase\Entries\NEW_20200724110812.doc"End Sub

New Document From Template

''EXAMPLE: how to create a new document from a document in an approved section of the shared drive.Dim result As BooleanDim qcDOC As DocumentDim templateName As String: templateName = "S:\APPROVED DOCUMENTS\Instruments\INF\INF.100.001.00 Repair Service Report.docx"Set qcDOC = Documents.Add(templateName)

Word VBA Save Document

Save as word document.

'Specify report folderDim reportDestinationFolder As StringreportDestinationFolder = "C:\Meetings\Name of Meeting\"
'Specify report nameDim reportFileName As StringreportFileName = "reportname"
'Saving word documentwordDoc.SaveAs2 (reportDestinationFolder & reportFileName & ".doc")

Word VBA Export PDF

Save word document as PDF.

'Specify report folderDim reportDestinationFolder As StringreportDestinationFolder = "C:\Meetings\Name of Meeting\"
'Specify report nameDim reportFileName As StringreportFileName = "uniquereportname"
'Exporting PDFwordDoc.ExportAsFixedFormat _ OutputFileName:=reportDestinationFolder & reportFileName & ".pdf", _ ExportFormat:=wdExportFormatPDF

Save As PDF Button

'Used to access Content ControlsPrivate Const datetimeStamp As String = "datetimeStamp"
Private Sub btnSavePDF_Click()'Nolan Manteufel'21JUL2020
'Save PDF to location determined by ContentControl
'UserDim macroUser As StringmacroUser = Environ$("username")macroUser = LCase(macroUser)
'ComputerDim macroComputer As StringmacroComputer = Environ$("computername")macroComputer = LCase(macroComputer)
'DatetimeDim timeOnly As StringDim dateOnly As StringDim dateTime As StringtimeOnly = Format(Time, "hhmmss")dateOnly = Format(Date, "yyyymmdd")dateTime = dateOnly & timeOnly
Dim myDoc As DocumentSet myDoc = ActiveDocument
'PDF filenameDim PDFFILEPATHNAMEEXT As StringPDFFILEPATHNAMEEXT = myDoc.SelectContentControlsByTag("saveFolder")(1).Range.TextPDFFILEPATHNAMEEXT = PDFFILEPATHNAMEEXT & "\" & dateTime & "_" & macroUser & ".pdf"
'Set PDF stamp fieldsmyDoc.FormFields("savedBy").result = macroUsermyDoc.FormFields("savedAt").result = macroComputermyDoc.FormFields("savedDatetime").result = dateTimemyDoc.FormFields("savedPDF").result = PDFFILEPATHNAMEEXT
'Set footer datatime stampmyDoc.SelectContentControlsByTag(datetimeStamp)(1).SetPlaceholderText Text:=dateTime
'Save as PDFmyDoc.ExportAsFixedFormat _ OutputFileName:=PDFFILEPATHNAMEEXT, _ ExportFormat:=wdExportFormatPDF, _ OpenAfterExport:=False
'Clear footer datatime stampmyDoc.SelectContentControlsByTag(datetimeStamp)(1).SetPlaceholderText Text:=" "
'Clear PDF stamp fieldsmyDoc.FormFields("savedBy").result = vbNullStringmyDoc.FormFields("savedAt").result = vbNullStringmyDoc.FormFields("savedDatetime").result = vbNullStringmyDoc.FormFields("savedPDF").result = vbNullString
MsgBox ("Congratulations, your PDF has been saved successfully.")
End Sub

Page updated

Google Sites

Report abuse