How to Generate a Page for Each Day of Month in Microsoft Word using VBA
I briefly joined my wife at her practice to help her grow the business and figure out how to make things more efficient. One of the things I learned is that my wife created a sign-in sheet for the office in Microsoft Word. Every week she would open the file and manually enter the date for each day of the week and then print out the documents. I took over the responsibility for a month and it annoyed me due to how inefficient the process was and I decided to automate the entire thing. I couldn’t find a solution to the problem online so I had to roll my own and am sharing the code in case someone else can benefit from it.
Important Details
The script will calculate the first day and last day of the month and then do a loop to append the date in the “Day, Month day, Year” format (i.e. Thursday July 17, 2019) to a text field.
There are a few important steps involved to get the script working as is:
- Create a Word doc with the first page that you want to duplicate.
- Add a text field from the developer tab. To copy and paste the code below as-is, you’ll need to name it txtDate. This is where the date will be added. If you want a different field name, change the name at line 26 and 83. You can also change the date formats to suit your needs here as well.
- Add a second blank page to the document. I was running into issues where the paste was appearing partially on the first. The blank page resolved this and I added code to remove the original page as well as the blank one from the beginning.
How to Use
Open up Word, then open up VBA, and copy and paste this snippet into a module. When you run the function, it’ll create a copy for every day of the month. I also created a function to start at a specific date in case you run it in the middle of the month.
Sub CreateSigninsForMonth()
Dim N As Integer
Dim sCurrentMonth, sCurrentYear As String
Dim sNewDate As String
N = 1
Count = Day(GetLastDayOfMonth)
For CopyNumber = 1 To Count
With Selection
.GoTo wdGoToPage, wdGoToAbsolute, 1
.Bookmarks("\Page").Range.Copy
.Paste
End With
With ActiveSheet
sCurrentMonth = Format(Date, "mmmm")
sCurrentYear = Format(Date, "yyyy")
sNewDate = (CopyNumber & " " & sCurrentMonth & " " & sCurrentYear)
ActiveDocument.FormFields("txtDate").Result = Format(sNewDate, "DDDD MMMM dd, YYYY")
End With
N = N + 1
Next CopyNumber
'Delete template + blank page
For i = 1 To 2
With ActiveDocument
strt = .GoTo(wdGoToPage, wdGoToLast).Start
Set r = .Range(strt - 1, .Range.End)
r.Delete
End With
Next
End Sub
Sub CreateSigninsForMonthStartingDate()
Dim Count As Integer
Dim N As Integer
Dim sCurrentMonth, sCurrentYear As String
Dim sNewDate, sEndDay As String
N = 1
Count = 0
iStartDay = InputBox("Which day do you want to start on?", "Starting Day", "1")
Count = InputBox("Which day do you want to end on?", "Ending Day", Day(GetLastDayOfMonth))
Do While Count > Day(GetLastDayOfMonth)
sEndDay = InputBox("Which day do you want to end on?", "Ending Day", Day(GetLastDayOfMonth))
If iStartDay = vbNullString Or sEndDay = vbNullString Then
MsgBox "You clicked cancel.", vbOKOnly, "Try again later!"
Exit Sub
End If
If IsNumeric(CInt(sEndDay)) Then
Count = CInt(sEndDay)
End If
Loop
For CopyNumber = iStartDay To Count
With Selection
.GoTo wdGoToPage, wdGoToAbsolute, 1
.Bookmarks("\Page").Range.Copy
.Paste
End With
With ActiveSheet
sCurrentMonth = Format(Date, "mmmm")
sCurrentYear = Format(Date, "yyyy")
sNewDate = (CopyNumber & " " & sCurrentMonth & " " & sCurrentYear)
ActiveDocument.FormFields("txtDate").Result = Format(sNewDate, "DDDD MMMM dd, YYYY")
End With
N = N + 1
Next CopyNumber
'Delete template + blank page
For i = 1 To 2
With ActiveDocument
strt = .GoTo(wdGoToPage, wdGoToLast).Start
Set r = .Range(strt - 1, .Range.End)
r.Delete
End With
Next
End Sub
Function GetFirstDayOfMonth(Optional dtmDate As Date = 0) As Date
' Return the first day in the specified month.
If dtmDate = 0 Then
' Use the current date if none was specified
dtmDate = Date
End If
GetFirstDayOfMonth = DateSerial(Year(dtmDate), Month(dtmDate), 1)
End Function
Function GetLastDayOfMonth(Optional dtmDate As Date = 0) As Date
' Return the last day in the specified month.
If dtmDate = 0 Then
' Use the current date if none was specified
dtmDate = Date
End If
GetLastDayOfMonth = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 0)
End FunctionHow to get shape type in Visio using VBA?
I’m working with a Visio 2016 file with over 100 tabs and need to extract the data (mainly text, connector from/to, and shape) for data processing for a processing engine. I was trying to figure out how to get the shape type name in Visio using VBA. For example, in a flowchart, I’m trying to figure out how to tell if a shape is a process, decision, data, etc. The
visShape.Typeproperty seems to always return 3 which appears to be visTypeShape from https://docs.microsoft.com/en-us/office/vba/api/visio.visshapetypes. After hunting through all the available properties on the Shape object, I found that the shape.Master.Name property will return the shape name, but you need to check if it’s Nothing first in case it’s not a shape.
I didn’t do that and it kept breaking the script originally because some of the pages had text fields and the first few items on the first sheet I was working with were text boxes. Hopefully this snippet will save you the time I wasted figuring it out.
Public Sub GetShapeAndID()
Dim visShape As Shape
For Each visShape In ActivePage.Shapes
If Not visShape.Master Is Nothing Then
Debug.Print visShape.ID & " - " & visShape.Master.Name
End If
Next
End Sub