VBA
Code behind menu form, f_MENU_FONT_List
Specify short or long list.
Click button to create Word document.
Check 'Watch Progress' to see the Word document as its being created.
This takes more time for the code to run but is interesting to watch.
Check 'Match Pattern' to evaluate each font name with a pattern,
to see if it should be included.
And then specify the pattern you desire.
Default is to skip font names beginning with @
You can also click buttons to go to the VBA code for each major step.
Calls code in module:
- mod_Word_Make_FONT_LIST_s4p
Procedures:
- UpdateProgress (Public)
- Form_Load
- cmd_Word_Make_Font_List_Click
- cmd_VBA_WordApp_Create_Click
- cmd_VBA_WordDoc_GetNew_Click
- cmd_VBA_Word_Margins_Narrow_Click
- cmd_VBA_WordTable_Make_Click
- cmd_VBA_WordTable_Borders_Click
- cmd_VBA_WriteData_Click
- cmd_VBA_WordDoc_Header_Click
- cmd_VBA_WordDoc_SaveClose_Click
- cmd_VBA_WordApp_Release_Click
Option Compare Database
Option Explicit
' 230316 cmd_Word_FontList
' cbf: f_MENU_FONT_List
'*************** Code Start ***************************************************
' Purpose : code behind form to List Windows Fonts installed using Word
' Author : crystal (strive4peace)
' Code List: https://MsAccessGurus.com/code.htm
' This Code: https://msaccessgurus.com/tool/aWord_FontList.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Mark your changes. Use at your own risk.
'--------------------------------------------------------------------------------
' Public UpdateProgress
'--------------------------------------------------------------------------------
Public Sub UpdateProgress(psMessage As String)
'230314 s4p
Me.Label_Progress.Caption = psMessage
End Sub
'--------------------------------------------------------------------------------
' Form_Load
'--------------------------------------------------------------------------------
Private Sub Form_Load()
'230314 s4p
Call UpdateProgress( " ")
End Sub
'--------------------------------------------------------------------------------
' chk_MatchPattern_AfterUpdate
'--------------------------------------------------------------------------------
Private Sub chk_MatchPattern_AfterUpdate()
'230316
With Me
If .chk_MatchPattern <> False Then
.txtPattern.SetFocus
End If
End With
End Sub
'--------------------------------------------------------------------------------
' cmd_Word_FontList_Click
'--------------------------------------------------------------------------------
Private Sub cmd_Word_FontList_Click()
'230314 strive4peace, 230316
'Calls
' Word_Make_Font_List_s4p
Dim iShortLong As Integer
Dim sPattern As String
Dim bWatchProgress As Boolean
With Me
If .chk_MatchPattern <> False Then
sPattern = .txtPattern
Else
sPattern = ""
End If
iShortLong = Nz(.fra_ShortLong,1)
bWatchProgress = Nz(.chk_WatchProgress,0)
End With
Call Word_Make_Font_List_s4p( _
iShortLong,sPattern,bWatchProgress _
)
End Sub
'--------------------------------------------------------------------------------
' Open VBA Code
'--------------------------------------------------------------------------------
'~~~~~~~~~~~~~~~ mod_Word_Application_Document_s4p
Private Sub cmd_VBA_WordApp_Create_Click()
'230314 strive4peace
DoCmd.OpenModule "mod_Word_Application_Document_s4p", "WordApp_Create"
End Sub
Private Sub cmd_VBA_WordDoc_GetNew_Click()
'230314 strive4peace
DoCmd.OpenModule "mod_Word_Application_Document_s4p", "WordDoc_GetNew"
End Sub
'~~~~~~~~~~~~~~~ mod_Word_Margins_s4p
Private Sub cmd_VBA_Word_Margins_Narrow_Click()
'230314 strive4peace
DoCmd.OpenModule "mod_Word_Margins_s4p", "Word_Margins_Narrow"
End Sub
'~~~~~~~~~~~~~~~ mod_Word_Table_s4p
Private Sub cmd_VBA_WordTable_Make_Click()
'230314 strive4peace
DoCmd.OpenModule "mod_Word_Table_s4p", "WordTable_Make"
End Sub
Private Sub cmd_VBA_WordTable_Borders_Click()
'230314 strive4peace
DoCmd.OpenModule "mod_Word_Table_s4p", "WordTable_Borders"
End Sub
'~~~~~~~~~~~~~~~ mod_Word_Make_FONT_LIST_s4p
Private Sub cmd_VBA_WriteData_Click()
'230314 strive4peace
DoCmd.OpenModule "mod_Word_Make_FONT_LIST_s4p", "Word_Make_Font_List_s4p"
End Sub
'~~~~~~~~~~~~~~~ mod_Word_Header_s4p
Private Sub cmd_VBA_WordDoc_Header_Click()
'230314 strive4peace
DoCmd.OpenModule "mod_Word_Header_s4p", "WordDoc_Header"
End Sub
'~~~~~~~~~~~~~~~ mod_Word_Application_Document_s4p
Private Sub cmd_VBA_WordDoc_SaveClose_Click()
'230314 strive4peace
DoCmd.OpenModule "mod_Word_Application_Document_s4p", "WordDoc_SaveClose"
End Sub
Private Sub cmd_VBA_WordApp_Release_Click()
'230314 strive4peace
DoCmd.OpenModule "mod_Word_Application_Document_s4p", "WordApp_Release"
End Sub
'*************** Code End *****************************************************
Goto Top
mod_Word_Make_FONT_LIST_s4p
Calls code in modules:
- mod_Word_Application_Document_s4p
- mod_Word_Margins_s4p
- mod_Word_Table_s4p
- mod_Word_Header_s4p
Procedures:
- writePROGRESS
- Word_Make_Font_List_s4p
<Option Compare Database
Option Explicit
'2303126 psPattern, sDocHeader
'*************** Code Start *****************************************************
' module name: mod_Word_Make_Fonts_List_s4p
'-------------------------------------------------------------------------------
' Purpose : VBA to create a list of Fonts installed in Windows using Word
' Author : crystal (strive4peace)
' Code List: https://MsAccessGurus.com/code.htm
' This Code: https://msaccessgurus.com/tool/aWord_FontList.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
'early binding needs reference to:
' Microsoft Word #.# Object Library
' Public variables defined and set in
' mod_Word_Application_Document_s4p
'
'-------------------------------------------------------------------------------
' writePROGRESS
'-------------------------------------------------------------------------------
Sub writePROGRESS(psMessage As String) '--- customize
'230315 strive4peace. Send " " to clear message
Call Form_f_MENU_FONT_List.UpdateProgress(psMessage)
If psMessage = " " Then
'clear message ob status bar
SysCmd acSysCmdClearStatus
Else
Dim sMessageStatus As String
sMessageStatus = Replace(psMessage,vbCrLf, " ")
SysCmd acSysCmdSetStatus,sMessageStatus
End If
End Sub
'-------------------------------------------------------------------------------
' Word_Make_Font_List_s4p
'-------------------------------------------------------------------------------
Sub Word_Make_Font_List_s4p( _
Optional piShortLong As Integer = 1 _
,Optional psPattern As String = "" _
,Optional pbWatchProgress As Boolean = True _
)
'220420 strive4peace, 220530, 230314, 5 230316
'make a Word document showing examples of all the installed fonts
'CALLS
' writePROGRESS - write progress message to menu form
' WordApp_Create - set goWord
' WordDoc_GetNew - return Document
' WordTable_Make
' -- then write data
' Word_Margins_Narrow
' WordTable_Borders
' WordDoc_Header
' WordDoc_SaveClose
' WordApp_Release
'
'USES
' WizHook.SortStringArray
On Error GoTo Proc_Err
'early binding
' Dim oDoc As Word.Document
' Dim oRange As Word.Range
' Dim oTable As Word.Table
'late binding
Dim oDoc As Object
Dim oRange As Object
Dim oTable As Object
Dim sText As String _
,sPath As String _
,sFilename As String _
,sDocHeader As String _
,sFontName As String _
,sMsg As String _
,sgTimer As Single
Dim i As Integer _
,iRow As Integer _
,iRows As Integer _
,iCountPattern As Integer
Dim asFont() As String
Dim aHeadArray(1 To 2) As String
sgTimer = Timer
sDocHeader = IIf(piShortLong = 1, "Short ", "Long ") _
& "Font List" _
& IIf(psPattern <> "" _
, " for pattern " & psPattern _
, "")
sFilename = "FontList_" _
& IIf(psPattern <> "", "Pattern_", "") _
& IIf(piShortLong = 1, "Short", "Long") _
& "_s4p_"
iCountPattern = 0
'--------------------------------------- Setup Word
Call writePROGRESS( "set up Word")
'create goWord application object
Call WordApp_Create
'make and return new Word document
Set oDoc = WordDoc_GetNew
'set narrow page margins
Call Word_Margins_Narrow(oDoc)
'--------------------------------------- Write Data
Call writePROGRESS( "write text and hyperlink")
'write stuff at beginning to describe document
sText = "Download Access database with VBA" _
& " and a menu form to create this document: "
With oDoc
.Range.InsertAfter sText
.Range.Collapse 0
Set oRange = oDoc.Range
oRange.Collapse 0
.Hyperlinks.Add Anchor:=oRange _
,Address:= "https://msaccessgurus.com/tool/aWord_FontList.htm" _
,TextToDisplay:= "https://msaccessgurus.com/tool/aWord_FontList.htm"
End With
With oDoc.Range
.Collapse 0
.InsertParagraphAfter
End With
Call writePROGRESS( "assign example string")
'make string for example
If piShortLong = 1 Then
sText = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & " " _
& "abcdefghijklmnopqrstuvwxyz"
Else
sText = Chr(32) 'space in standard fonts
For i = 33 To 254
sText = sText & Chr(i)
'add space every 10 characters
If i Mod 10 = 0 Then
sText = sText & " "
End If
Next i
End If
'set range to end of document
Set oRange = oDoc.Content
oRange.Collapse (0) '0=wdCollapseEnd
'count rows
iRows = goWord.fontnames.Count
Call writePROGRESS( "get and sort font names")
'make array with all the font names
ReDim asFont(1 To iRows)
iCountPattern = 0
For i = 1 To iRows
sFontName = goWord.fontnames(i)
If psPattern <> "" Then
If Not sFontName Like psPattern Then
GoTo proc_NextFont
End If
End If
iCountPattern = iCountPattern + 1
asFont(iCountPattern) = sFontName
proc_NextFont:
Next i
'redimension array if there was a pattern
If iCountPattern < 1 Then
MsgBox "No font names match the pattern: " & psPattern _
,, "Aborting document creation"
oDoc.Close SaveChanges:=False
GoTo Proc_Exit
End If
If iCountPattern <> iRows Then
ReDim Preserve asFont(1 To iCountPattern)
End If
'sort array of font names
WizHook.SortStringArray asFont
'pause
Call writePROGRESS( "table" _
& vbCrLf & vbCrLf & "with specified number of rows and columns")
'make Word table at end of document with
' 1 row for each font + row for heading
' 2 columns
' skip Caption
aHeadArray(1) = "Font Name"
aHeadArray(2) = "Example"
Set oTable = WordTable_Make(oDoc,oRange,iCountPattern + 1,2 _
, "",aHeadArray)
Call writePROGRESS( "table" _
& vbCrLf & vbCrLf & "set column widths")
With oTable
'1. FontName, 2. Example
'----------------------- Column widths
.Columns(1).PreferredWidth = CInt(1.8 * 72)
.Columns(2).PreferredWidth = CInt(5.7 * 72)
End With
Call writePROGRESS( "table" _
& vbCrLf & vbCrLf & "borders")
Call WordTable_Borders(oTable)
iRow = 1 'allow for heading row
With oTable
For i = LBound(asFont) To UBound(asFont)
sFontName = asFont(i)
Call writePROGRESS( "write data" _
& vbCrLf & vbCrLf & sFontName)
iRow = iRow + 1
.Cell(iRow,1).Range.Text = sFontName
With .Cell(iRow,2).Range
If pbWatchProgress <> False Then
.Select ' watch the progress
End If
.Text = sText
.Font.Name = sFontName
End With
Next i
End With 'oTable
'--------------------------------------- Page Header
Call writePROGRESS( "page header")
Call WordDoc_Header(oDoc,sDocHeader)
'list how many fonts are listed at end of document
Call writePROGRESS( "count fonts ")
With oDoc.Content
.InsertParagraphAfter
.InsertParagraphAfter
sMsg = Format(iRows, "#,###") & " fonts installed"
If iCountPattern <> iRows Then
sMsg = sMsg & ", " _
& Format(iCountPattern, "#,###") & " listed"
End If
.InsertAfter sMsg
End With 'oDoc.Content
'goto the first page for a good leave
'1=wdGoToPage
'-1=wdGoToLast
'1=wdGoToFirst
oDoc.Goto 1,1
'--------------------------------------- Save and Close Document
Document_Save:
Call writePROGRESS( "Save and Close Document")
'get updated sFilename back
Call WordDoc_SaveClose(oDoc _
,sFilename _
, "strive4peace",,sPath)
sgTimer = Timer - sgTimer
If sgTimer > 60 Then
sMsg = sMsg & vbCrLf _
& sgTimer \ 60 & " minutes, " _
& Format(sgTimer - (sgTimer \ 60) * 60, "#.#") & " seconds"
Else
sMsg = sMsg & vbCrLf _
& Format(sgTimer, "#.#") & " seconds"
End If
If pbWatchProgress <> False Then
sMsg = sMsg & ", watching progress"
End If
sMsg = sPath _
& vbCrLf & sFilename _
& vbCrLf & vbCrLf & sMsg
'--------------------------------------- Open Word
Call writePROGRESS(sMsg)
sMsg = sMsg _
& vbCrLf & vbCrLf & "Open the path?"
If MsgBox(sMsg,vbYesNo, "Done") = vbYes Then
Call Shell( "Explorer.exe" & " " & sPath,vbNormalFocus)
End If
Call writePROGRESS( " ") 'clear message
Proc_Exit:
Set oRange = Nothing
Set oTable = Nothing
Set oDoc = Nothing
Call WordApp_Release
Exit Sub
Proc_Err:
MsgBox Err.Description _
,, "ERROR " & Err.Number _
& " Word_Make_Font_List_s4p"
Resume Proc_Exit
Resume
End Sub
'*************** Code End *******************************************************
Goto Top
mod_Word_Application_Document_s4p
Sets global object variable:
Sets global constant:
Procedures:
- WordApp_Create
- WordApp_Release
- WordDoc_GetNew
- WordDoc_SaveClose
- GetDesktopPath
- MakeAPath
Option Compare Database
Option Explicit
'230316 pbWatchProgress
'*************** Code Start *****************************************************
' module name: mod_Word_Application_Document_s4p
'-------------------------------------------------------------------------------
' Purpose : VBA to set, save, and release Word application and Word Document
' and code to get desktop path and make a path
' Author : crystal (strive4peace)
' Code List: https://MsAccessGurus.com/code.htm
' This Code: https://msaccessgurus.com/tool/aWord_FontList.htm
'
' Sub WordApp_Create
' set public goWord variable for Word.Application as object for late-binding
' Sub WordApp_Release
' release goWord Word.Application
' Function WordDoc_GetNew
' make a new Word.Document and return the object for late-binding
' Function WordDoc_SaveClose
' save Word document as file on desktop or in folder
' Return Path\Filename.Ext
' Return Path in psReturnPath
' Function GetDesktopPath
' Return Path
' Function MakeAPath
' send path, return True if there or created
'
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
' Public variables
'-------------------------------------------------------------------------------
Const gbEarly As Boolean = False
#Const IsEarly = gbEarly
Private mbWordQuit As Boolean
'early binding needs reference to:
' Microsoft Word #.# Object Library
#If IsEarly = True Then
'early binding
Public goWord As Word.Application
' Public goDoc As Word.Document
' Public goField As Word.Field
' Public goRange As Word.Range
#Else
'late binding
Public goWord As Object
' Public goDoc As Object
' Public goField As Object
' Public goRange As Object
#End If
'-------------------------------------------------------------------------------
' WordApp_Create
'-------------------------------------------------------------------------------
Public Sub WordApp_Create()
'220420 strive4peace, 230314
'set public goWord variable for Word.Application
mbWordQuit = False 'default value
'if Word is already open, use that instance
On Error Resume Next
Set goWord = GetObject(, "Word.Application")
On Error GoTo Proc_Err
If goWord Is Nothing Then
'Word wasn't open - create global Word application object
Set goWord = CreateObject( "Word.Application")
mbWordQuit = True
End If
Proc_Exit:
On Error Resume Next
Exit Sub
Proc_Err:
MsgBox Err.Description _
,, "ERROR " & Err.Number _
& " WordApp_Create"
Resume Proc_Exit
Resume
End Sub
'-------------------------------------------------------------------------------
' WordApp_Release
'-------------------------------------------------------------------------------
Public Sub WordApp_Release()
'220420 strive4peace, 221108, 230315
'release goWord Word.Application
On Error GoTo Proc_Err
' Set goField = Nothing
'if Word application was started, then Quit
If mbWordQuit = True Then
' If Not goDoc Is Nothing Then
' 'close document and don't save changes
' goDoc.Close False
' End If
goWord.Quit
End If
' Set goDoc = Nothing
'release Word application object
Set goWord = Nothing
Proc_Exit:
On Error Resume Next
Exit Sub
Proc_Err:
MsgBox Err.Description _
,, "ERROR " & Err.Number _
& " WordApp_Release"
Resume Proc_Exit
Resume
End Sub
'-------------------------------------------------------------------------------
' WordDoc_GetNew
'-------------------------------------------------------------------------------
Public Function WordDoc_GetNew( _
Optional pbWatchProgress As Boolean = True _
) As Object 'Word.Document
'220420 strive4peace, 221314
'make a new Word.Document and return the object
'set goWord -- create or use Word.Application
'set Visible to True and Activate the window
'RETURN
' Word.Document (object for late binding)
'CALLS
' WordApp_Create
'Initialize Word
If goWord Is Nothing Then
Call WordApp_Create
End If
With goWord
If pbWatchProgress <> False Then
' make Word visible
.Visible = True
End If
'make a new Word document and return the object
Set WordDoc_GetNew = .Documents.Add
End With
Proc_Exit:
On Error Resume Next
Exit Function
Proc_Err:
MsgBox Err.Description _
,, "ERROR " & Err.Number _
& " WordDoc_GetNew"
Resume Proc_Exit
Resume
End Function
'-------------------------------------------------------------------------------
' WordDoc_SaveClose
'-------------------------------------------------------------------------------
' Word.Document
Public Function WordDoc_SaveClose( _
oDoc As Object _
,ByRef psFilename As String _
,Optional psFolderOrPath As String = "" _
,Optional psFormatDateTime As String = "yymmdd_hhnn" _
,Optional psReturnPath As String _
) As String
'220420 strive4peace, ... 230314, 15
'save Word document as file on desktop or in folder
'Return Path\Filename.Ext
'Return Path in psReturnPath
'if psFolderOrPath specified, path is that folder on the desktop
' if path is absolute and use that instead
'if no file extension specified, default will be added
'oDoc is the document object
' CALLs
' GetDesktopPath
' MakeAPath
' EXAMPLE:
' CALL WordDoc_SaveClose(oDoc, "Word_Styles_s4p_", "strive4peace",,sPath)
'PARAMETERS
' oDoc is the Word document object
' psFilename is what to call the file, with or without an extension
' psFolderOrPath is a folder name on the desktop
' psFormatDateTime is the date/time format to add, "" to skip
' psReturnPath is the Path
'RETURN
' Path\Filename.Ext
'CALLS
' GetDesktopPath
' MakeAPath
On Error GoTo Proc_Err
Dim sPath As String _
,sPathFile As String
'if full path specified, use it
If InStr(psFolderOrPath, ":") > 0 Then
sPath = psFolderOrPath
Else
'get desktop path ending with \
sPath = GetDesktopPath(True)
If psFolderOrPath <> "" Then
'make or use a folder on the desktop
If MakeAPath(sPath & psFolderOrPath & "\") <> False Then
sPath = sPath & psFolderOrPath & "\"
End If
End If
End If
If Right(sPath,1) <> "\" Then
sPath = sPath & "\"
End If
sPathFile = sPath & psFilename _
& IIf(psFormatDateTime <> "", "_" & Format(Now,psFormatDateTime), "")
oDoc.SaveAs sPathFile
'return path in a parameter
psReturnPath = sPath
'return full path and filename with extension
WordDoc_SaveClose = oDoc.FullName
'update filename and pass back
psFilename = oDoc.Name
'close document without saving
oDoc.Close SaveChanges:=False
Proc_Exit:
On Error Resume Next
Exit Function
Proc_Err:
MsgBox Err.Description _
,, "ERROR " & Err.Number _
& " WordDoc_SaveClose"
Resume Proc_Exit
Resume
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' GetDesktopPath
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function GetDesktopPath( _
Optional pbAddTrailBackslash As Boolean = False _
) As String
With CreateObject( "WScript.Shell")
GetDesktopPath = .specialfolders( "Desktop") _
& IIf(pbAddTrailBackslash, "\", "")
End With
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' MakeAPath
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function MakeAPath( _
psPath As String) As Boolean
'crystal (strive4peace) ...190204
'set up error handler
On Error GoTo Proc_Err
'initialize return value to be False for not successful
MakeAPath = False
'if directory is already there, return True and exit
If Len(Dir(psPath,vbDirectory)) > 0 Then
MakeAPath = True
GoTo Proc_Exit
End If
'dimension variables
Dim i As Integer _
,iPos As Integer _
,sPath As String
'add backslash to end of path if necessary
iPos = 1
If Right(psPath,1) <> "\" Then psPath = psPath & "\"
'get position of first backslash
iPos = InStr(iPos,psPath, "\")
'loop through directories of path and make folders
Do While iPos > 0
sPath = Left(psPath,iPos)
If Len(Dir(sPath,vbDirectory)) = 0 Then
MkDir sPath
DoEvents
End If
'set start search position to be 1 + position of last backslash found
iPos = InStr(iPos + 1,psPath, "\")
Loop
'if folder exists, then return True and exit
If Len(Dir(psPath,vbDirectory)) > 0 Then
MakeAPath = True
End If
'exit code
Proc_Exit:
On Error Resume Next
Exit Function
'if there is an error, then resume with exit code
Proc_Err:
Resume Proc_Exit
End Function
'*************** Code End *******************************************************
Goto Top
mod_Word_Margins_s4p
Procedures:
- Word_Margins_Narrow
- Word_Margins_1inch
- Word_Margins
'*************** Code Start *****************************************************
' module name: mod_Word_Margins_s4p
'-------------------------------------------------------------------------------
' Purpose : VBA to set margins in a Word document
' uses Document.PageSetup
' Author : crystal (strive4peace)
' Code List: https://MsAccessGurus.com/code.htm
' This Code: https://msaccessgurus.com/tool/aWord_FontList.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Use at your own risk.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' 72 points in an inch
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Word_Margins_Narrow
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub Word_Margins_Narrow(oDoc As Object)
'make margins 0.5 inches on all sides
With oDoc.PageSetup
.TopMargin = CInt(0.5 * 72) 'InchesToPoints
.BottomMargin = CInt(0.5 * 72) 'InchesToPoints
.LeftMargin = CInt(0.6 * 72) 'InchesToPoints
.RightMargin = CInt(0.5 * 72) 'InchesToPoints
End With
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Word_Margins_1inch
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub Word_Margins_1inch(oDoc As Object)
'make margins 1 inch on all sides
With oDoc.PageSetup
.TopMargin = 72 'InchesToPoints
.BottomMargin = 72 'InchesToPoints
.LeftMargin = 72 'InchesToPoints
.RightMargin = 72 'InchesToPoints
End With
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Word_Margins
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub Word_Margins(oDoc As Object _
,pInchTop As Double _
,pInchBottom As Double _
,pInchLeft As Double _
,pInchRight As Double _
)
'send what you want for each margin in inches
With oDoc.PageSetup
.TopMargin = CInt(pInchTop * 72) 'InchesToPoints
.BottomMargin = CInt(pInchBottom * 72) 'InchesToPoints
.LeftMargin = CInt(pInchLeft * 72) 'InchesToPoints
.RightMargin = CInt(pInchRight * 72) 'InchesToPoints
End With
End Sub
'*************** Code End *******************************************************
Goto Top
mod_Word_Table_s4p
Procedures:
- WordTable_Make
- WordTable_Borders
'*************** Code Start *****************************************************
' module name: mod_Word_Table_s4p
'-------------------------------------------------------------------------------
' Purpose : VBA to create a table and add borders to a table in Word
' Author : crystal (strive4peace)
' Code List: https://MsAccessGurus.com/code.htm
' This Code: https://msaccessgurus.com/tool/aWord_FontList.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' WordTable_Make
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function WordTable_Make(oDoc As Object _
,oRange As Object _
,ByVal pnRows As Long _
,ByVal pnCols As Long _
,ByVal psCaption As String _
,pasHeadArray() As String _
) As Object 'As Word.Table
'strive4peace 170811, 20202, 220420,230309
'early binding
' Dim oTable As Word.Table
'late binding
Dim oTable As Object
Dim i As Integer
'insert table
With oDoc
Set oTable = .Tables.Add( _
Range:=oRange _
,NumRows:=pnRows _
,NumColumns:=pnCols _
)
End With
If (psCaption <> "") Then
'insert caption
oDoc.Application.Selection.InsertCaption _
Label:= "Table" _
,title:=psCaption _
,Position:=0 _
,ExcludeLabel:=0
End If
With oTable
'Position - wdCaptionPositionAbove=0
' .ApplyStyleHeadingRows = True
.TopPadding = 0
.BottomPadding = 0
.LeftPadding = 2 'points
.RightPadding = 2
.Spacing = 0 'Auto
.AllowPageBreaks = True
.AllowAutoFit = False
'mark heading row
.Rows(1).HeadingFormat = True
'dont allow rows to break
.Rows.AllowBreakAcrossPages = False
'no space above text between paragraphs
.Range.Paragraphs.SpaceBefore = 0
'Vertical Alignment is Center
.Range.Cells.VerticalAlignment = 1 ' 1=wdCellAlignVerticalCenter
'Heading Row
For i = LBound(pasHeadArray) To UBound(pasHeadArray)
.Cell(1,i).Range.Text = pasHeadArray(i)
Next i
End With
Set WordTable_Make = oTable
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' WordTable_Borders
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub WordTable_Borders(oTable As Object) 'Word.Table
's4p 170811, 230314
On Error Resume Next
Dim i As Integer
With oTable
For i = -1 To -6 Step -1
'wdBorderTop =-1
'wdBorderLeft = -2
'wdBorderBottom =-3
'wdBorderRight= -4
'wdBorderHorizontal = -5
'wdBorderVertical = -6 -- error?
With .Borders(i)
.LineStyle = 1 'wdLineStyleSingle=1
.LineWidth = 8 'wdLineWidth100pt=8. wdLineWidth150pt=12
.Color = RGB(200,200,200) 'medium-light gray
End With
Next i
End With
'change borders to black for first row
With oTable.Rows(1)
For i = -1 To -4 Step -1
With .Borders(i)
.Color = 0 'wdColorBlack = 0
End With
Next i
'Shading for header row
.Shading.BackgroundPatternColor = RGB(232,232,232)
End With 'first row
'Not used:
' 'wdLineStyleNone = 0
' .Borders(-7).LineStyle = 0 'wdBorderDiagonalDown =-7
' .Borders(-8).LineStyle = 0 'wdBorderDiagonalUp =-8
End Sub
'*************** Code End *******************************************************
Goto Top
mod_Word_Header_s4p
Procedures:
'*************** Code Start *****************************************************
' module name: mod_Word_Header_s4p
'-------------------------------------------------------------------------------
' Purpose : VBA to create a new Word document and set Header
' Author : crystal (strive4peace)
' Code List: https://MsAccessGurus.com/code.htm
' This Code: https://msaccessgurus.com/tool/aWord_FontList.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
Const InchToPoint = 72
'early binding needs reference to:
' Microsoft Word #.# Object Library
'-------------------------------------------------------------------------------
' WordDoc_Header
'-------------------------------------------------------------------------------
Sub WordDoc_Header(oDoc As Object _
,psTitle As String _
,Optional pbAddHeading12 As Boolean = False)
'220530 strive4peace, 230314
Dim sgTabMiddle As Single
With oDoc.PageSetup
sgTabMiddle = .PageWidth - .LeftMargin - .RightMargin
End With
Dim oRange As Object
'1= wdHeaderFooterPrimary
Set oRange = oDoc.Sections(1).Headers(1).Range
With oDoc
If pbAddHeading12 = True Then
'reference to Heading 1
' -1=wdFieldEmpty, False= Don't PreserveFormatting
'reference oDoc
.Fields.Add oRange,-1 _
, "STYLEREF " & Chr(34) & "Heading 1" & Chr(34),False
Set oRange = .Sections(1).Headers(1).Range
'position cursor after field just added
oRange.Collapse 0 'wdCollapseEnd
' add comma space
oRange.InsertAfter ", "
'collapse to end
oRange.Collapse Direction:=0 'wdCollapseEnd
'reference to Heading 2
' -1=wdFieldEmpty
.Fields.Add oRange,-1 _
, "STYLEREF " & Chr(34) & "Heading 2" & Chr(34),False
Set oRange = .Sections(1).Headers(1).Range
oRange.Collapse Direction:=0
End If
'add TABs and text to align on right
oRange.InsertAfter vbTab & psTitle & ", " _
& "strive4peace, page "
oRange.Collapse Direction:=0
'reference to Page number
.Fields.Add oRange,-1, "Page",False
Set oRange = .Sections(1).Headers(1).Range
'collapse to end and
oRange.Collapse Direction:=0
'insert /
oRange.InsertAfter "/"
oRange.Collapse 0
'reference to total pages
oRange.Parent.Fields.Add oRange,-1, "NumPages",False
Set oRange = .Sections(1).Headers(1).Range
oRange.Collapse 0
'update fields
.Sections(1).Headers(1).Range.Fields.Update
'border line below paragraph
With oRange
With .ParagraphFormat
'6 point space after paragraph
.SpaceAfter = 6
'clear default tab stops
.TabStops.ClearAll
'right tab stop at 6.5 inches
'wdAlignTabRight=2
'wdTabLeaderSpaces=0
.TabStops.Add Position:=sgTabMiddle _
,Alignment:=2 _
,Leader:=0
End With 'ParagraphFormat
With .Borders(-3) 'wdBorderBottom =-3
.LineStyle = 1 'wdLineStyleSingle=1
.LineWidth = 8 'wdLineWidth100pt=8
.Color = RGB(75,75,75) 'dark gray
End With 'Borders
End With
.Range.Collapse 1 'goto beginning of document
End With
Set oRange = Nothing
End Sub
'*************** Code End *******************************************************
' Code was generated with colors using the free
Color Code add-in for Access.
