Auto-Create a monthly Sign in sheet for preschool students

jonwondon · Oct 20, 2020

The image below is what each page looks like. Above is space for the "Child Name" "Month" "Class"

School days are obviously Monday-Friday but they start on different days depending on what month it is. For example: Next month, November 2020's first school day will be Monday the 2nd (11/2/20). I'm trying to avoid going into the table and manually editing all the dates and days to correspond with the coming month. This task takes a good hour or two when running the front desk. Is there a way to auto generate this?

Right now the table is in word, but I feel like an excel spreadsheet would be best. Thanks in advance for your help.

Dave Patton · Oct 22, 2020

Click on the icon just below the F(x) shown below; this will copy my post
move to cell A1 on a clean sheet (no entries) and paste

copy the formula down
Custom format the dates etc. to your preferences
N.B. You can hide row 4.
You can edit the relevant days for 3,4,5 day weeks or relevant mix of days.

T202010b.xlsm

A

B

C

D

E

1

Day/Date

Time In

Parent Signature

Time In

Parent Signature

2

Start Year

Start Month

3

2020

11

November

Custom formatted to Month

4

5

6

7

8

4aa

Cell Formulas
Range	Formula
C3	C3	=DATE(A3,B3,1)
A4	A4	=DATE(A3,B3,0)
A5:A8	A5	=WORKDAY.INTL(A4,1,1,HolidayList)

Dossfm0q · Oct 23, 2020

With Print Set up Page

VBA Code:

Public Sub atoCreate()

Dim WB As Workbook: Set WB = Workbooks.Add
Dim OpnWB As Workbook

Dim WS As Worksheet: Set WS = WB.Worksheets(1)
Dim YY As Long, MM As Long, B As Long, R As Long
Dim FullName As String, DefltPath As String, Filename As String
Filename = "Monthly Sign in Sheet.xlsm"
DefltPath = Environ("USERPROFILE") & "\Desktop\"
FullName = DefltPath & Filename
        'Close File if Open
        On Error Resume Next
        Set OpnWB = GetObject(, "Excel.Application")
        Set OpnWB = GetObject(FullName)
        If Not OpnWB Is Nothing Then
        OpnWB.Close False
        End If
        If Len(Dir(FullName)) <> 0 Then Kill FullName
        On Error GoTo 0
       

YY = 2020 '<<<<<<<
MM = 9 '<<<<<<<<<<<<
Dim Rng As Range
    With WS
        .Name = "Monthly Sign Sheet"
        .Activate
        ActiveWindow.DisplayGridlines = False
        With .Cells(1, 1)
        .Value = YY
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .RowHeight = 25
        End With
       
        With .Cells(1, 2)
        .Value = MM
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        End With
       
        With .Cells(3, 1).Resize(1, 5)
            .Value = Array("Day/Date", "Time In", "Parent Signture", "Time Out", "Parent Signture")
       
            With .Interior
                .Pattern = xlSolid
                .Color = RGB(47, 117, 181)
            End With ' .Interior
            With .Font
                .Color = RGB(255, 255, 255)
            End With ' .Font
            .ColumnWidth = VBA.Array(15, 20, 25, 20, 25) '<<<<<<<<<<<<<<<<< Column Width
            .RowHeight = 30
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
        End With ' .Cells(3, 1).Resize(1, 5)
       
        With .Cells(4, 1).Resize(25, 1)
        .FormulaArray = "=TEXT(DATE($A$1,$B$1,(ROW()-ROW($A$4)+1))+(((CEILING((ROW()-ROW($A$4)+1)+IF(WEEKDAY(DATE($A$1,$B$1,1))=1,WEEKDAY(DATE($A$1,$B$1,1))+1-2,WEEKDAY(DATE($A$1,$B$1,1))-2),5)/5)-1)*2)+IF(WEEKDAY(DATE($A$1,$B$1,1))=1,1,0),""dddd"" & CHAR(10) & "" mm/dd/yyyy"")"
        .WrapText = True
        .RowHeight = 30
        .VerticalAlignment = xlCenter
        End With ' .Cells(4, 1).Resize(30, 1)
       
        With .Cells(3, 1).Resize(26, 5)
            For B = 7 To 12
                With .Borders(B)
                    .LineStyle = xlContinuous
                    .Color = RGB(0, 0, 0)
                    .Weight = xlThin
                End With
            Next
        End With ' .Cells(3, 1).Resize(31, 1)
   
        For R = 1 To 13 '<<<<<<<<<<<<<<<<<
       
             With .Cells(20 + R, 1).Resize(1, 5)
           
             .FormatConditions.Add Type:=xlExpression, Formula1:= _
                 "=MONTH(TRIM(MID(" & .Cells(1, 1).Address & ",FIND(CHAR(10)," & .Cells(1, 1).Address & ",1)+2,10)))<>$B$1"
             .FormatConditions(.FormatConditions.Count).SetFirstPriority
             With .FormatConditions(1).Font
                 .ThemeColor = xlThemeColorDark1
                 .TintAndShade = 0
             End With
             .FormatConditions(1).Borders(xlLeft).LineStyle = xlNone
             .FormatConditions(1).Borders(xlRight).LineStyle = xlNone
             .FormatConditions(1).Borders(xlBottom).LineStyle = xlNone
             .FormatConditions(1).StopIfTrue = False
            End With
           
        Next
           
            With .Spinners.Add(.Cells(1, 1).Left, .Cells(1, 1).Top, 18, .Cells(1, 1).Height)
                .Value = 2020
                .Min = 2015
                .Max = 2040
                .SmallChange = 1
                .LinkedCell = "$A$1"
                .Display3DShading = False
            End With
            With .Spinners.Add(.Cells(1, 2).Left, .Cells(1, 1).Top, 18, .Cells(1, 1).Height)
                .Value = 11
                .Min = 1
                .Max = 12
                .SmallChange = 1
                .LinkedCell = "$B$1"
                .Display3DShading = False
            End With
            '''''''''''''''''
                    Application.PrintCommunication = False
                    With .PageSetup
                        .PrintTitleRows = ""
                        .PrintTitleColumns = ""
                    End With
                    Application.PrintCommunication = True
                    .PageSetup.PrintArea = "$A$3:$E$28"
                    Application.PrintCommunication = False
                    With .PageSetup
                        .RightFooter = "&""-,Bold Italic""&K7030A0jonwondon"
                        .LeftMargin = 30
                        .RightMargin = 30
                        .TopMargin = 45
                        .BottomMargin = 40
                        .HeaderMargin = 40
                        .FooterMargin = 35
                        .CenterHorizontally = True
                        .CenterVertically = False
                        .Orientation = xlPortrait
                        .Zoom = False
                        .FitToPagesWide = 1
                        .FitToPagesTall = 1
                    End With
                    Application.PrintCommunication = True
            '''''''''''''''''
            On Error Resume Next
                Kill FullName
                .Parent.SaveAs Filename:=FullName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
            On Error GoTo 0
       
    End With ' WS

End Sub

My Aswer Is This · Oct 23, 2020

My Aswer Is This said:

Ok this script works the same as previous one but instead of entering 12,2020
Enter 12/2020

Trying always makes thing better.

VBA Code:

Sub Enter_Weekdays()
'Modified  10/22/2020  1:43:38 AM  EDT
On Error GoTo M
Application.ScreenUpdating = False
Columns(1).ColumnWidth = 20
Dim mm As String
Dim i As Long
Dim yy As Long
Dim anss As Long
Dim b As Long
Columns(1).ClearContents
b = 1
mm = InputBox("Enter Month then / then year", "Like This: 12/2020", Month(Date) & "/" & Year(Date))
Dim LString As String
Dim LArray() As String
LString = mm
LArray = Split(LString, "/")
mm = LArray(0)
yy = LArray(1)

Select Case mm
    Case 9, 4, 6, 11: mmm = 30
    Case 1, 3, 5, 7, 8, 10, 12: mmm = 31
    Case 2: mmm = 29
End Select

    For i = 1 To mmm
        anss = Weekday(DateAdd("d", i - 1, mm & "/1/" & yy))
            Select Case anss
                Case 2 To 6
                Cells(b, 1).Value = WeekdayName(anss) & vbNewLine & DateAdd("d", i - 1, mm & "/1/" & yy)
                b = b + 1
            End Select
    Next
Columns(1).AutoFit
Application.ScreenUpdating = True
Exit Sub
M:
MsgBox "You caused a error. Maybe " & vbNewLine & mm & "  is not a proper entry" & vbNewLine & "Entry should look like this" & vbNewLine & "12/2020"


End Sub

You have no answer as to will this script do what you want?

Dossfm0q · Oct 25, 2020

Hi
Don't worry about page setup, it won't affect file format or remove borders Trust me.

if you like this support us with Like

.
this file contains Ribbon Controls (export: Word , PDF and PRNT)

VBA Code:

'Option Explicit
Public Sub ToCreateMonthlySignSheet()

Application.ScreenUpdating = False

Dim WB As Workbook: Set WB = Workbooks.Add
Dim OpnWB As Workbook
Dim MdlFile As String, FileContent As String, TXT As String, TXT1 As String, TXT2 As String, Extn As String
Dim ZipFileName  As Variant, FolderName As Variant, CustomUIFolder As Variant, imageFolder As Variant, relsFolder As Variant
Dim fso As Object
Dim wShApp  As Object
Dim TextFile As Integer
TextFile = FreeFile
Dim file As Object
Dim YY As Long, MM As Long, B As Long, R As Long
Dim FullName As String, DefltPath As String, Filename As String
Filename = "Monthly Signin Sheet.xlsm"
DefltPath = Environ("USERPROFILE") & "\Desktop\"
FullName = DefltPath & Filename

ZipFileName = Replace(FullName, ".xlsm", ".zip")
FolderName = Replace(FullName, ".xlsm", "")

With WB
        Dim ws As Worksheet: Set ws = .Worksheets(1)
                'Close File if Open
                On Error Resume Next
                Set OpnWB = GetObject(, "Excel.Application")
                Set OpnWB = GetObject(FullName)
                If Not OpnWB Is Nothing Then
                OpnWB.Close False
                End If
                If Len(Dir(FullName)) <> 0 Then Kill FullName
                On Error GoTo 0
       
        YY = 2020 '<<<<<<<
        MM = 11 '<<<<<<<<<<<<
       
        Dim Rng As Range
            'Hide Fisrt Two Rows
            Rows("1:2").EntireRow.Hidden = True
       
            With ws
            'Freeze First Row
            With ActiveWindow
                .SplitColumn = 0
                .SplitRow = 1
            End With
            ActiveWindow.FreezePanes = True
           
           
                .Name = "Monthly Sign Sheet"
                .Activate
                ActiveWindow.DisplayGridlines = False
                With .Cells(1, 1)
                .Value = YY
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .RowHeight = 25
                End With
               
                With .Cells(1, 2)
                .Value = MM
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                End With
               
                With .Cells(3, 1).Resize(1, 5)
                    .Value = Array("Day/Date", "Time In", "Parent Signature", "Time Out", "Parent Signature")
               
                    With .Interior
                        .Pattern = xlSolid
                        .Color = RGB(47, 117, 181)
                    End With ' .Interior
                    With .Font
                        .Color = RGB(255, 255, 255)
                    .Name = "Times New Roman"
                    .Size = 13
                    .Bold = True
                    End With ' .Font
                    .ColumnWidth = VBA.Array(12, 17, 20, 17, 20) '<<<<<<<<<<<<<<<<< Column Width
                    .RowHeight = 30
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                End With ' .Cells(3, 1).Resize(1, 5)
               
                With .Cells(4, 1).Resize(25, 1)
                .FormulaArray = "=TEXT(DATE($A$1,$B$1,(ROW()-ROW($A$4)+1))+(((CEILING((ROW()-ROW($A$4)+1)+IF(WEEKDAY(DATE($A$1,$B$1,1))=1,WEEKDAY(DATE($A$1,$B$1,1))+1-2,WEEKDAY(DATE($A$1,$B$1,1))-2),5)/5)-1)*2)+IF(WEEKDAY(DATE($A$1,$B$1,1))=1,1,0),""dddd"" & CHAR(10) & "" mm/dd/yyyy"")"
                .WrapText = True
                .RowHeight = 30
                .VerticalAlignment = xlCenter
                    With .Font
                        .Color = RGB(0, 0, 0)
                    .Name = "Times New Roman"
                    .Size = 12
                    .Bold = True
                    End With ' .Font
               
                End With ' .Cells(4, 1).Resize(30, 1)
               
                With .Cells(3, 1).Resize(26, 5)
                    For B = 7 To 12
                        With .Borders(B)
                            .LineStyle = xlContinuous
                            .Color = RGB(0, 0, 0)
                            .Weight = xlThin
                        End With
                    Next
                End With ' .Cells(3, 1).Resize(31, 1)
           
                For R = 4 To 28 '<<<<<<<<<<<<<<<<<
               
                     With .Cells(R, 1).Resize(1, 5)
                   
                    .FormatConditions.Add Type:=xlExpression, Formula1:="=AND(MONTH(TRIM(MID(" & .Cells(1, 1).Address & ",FIND(CHAR(10)," & .Cells(1, 1).Address & ",1)+2,10)))=$B$1,MOD(ROWS($A$4:" & Cells(R, 1).Address(False, False) & "),2)=0)"
                    .FormatConditions(.FormatConditions.Count).SetFirstPriority
                    With .FormatConditions(1).Interior
                        .PatternColorIndex = xlAutomatic
                        .Color = RGB(203, 223, 241)
                        .TintAndShade = 0
                    End With
                    .FormatConditions(1).StopIfTrue = False
                    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                     .FormatConditions.Add Type:=xlExpression, Formula1:= _
                         "=MONTH(TRIM(MID(" & .Cells(1, 1).Address & ",FIND(CHAR(10)," & .Cells(1, 1).Address & ",1)+2,10)))<>$B$1"
                     .FormatConditions(.FormatConditions.Count).SetFirstPriority
                     With .FormatConditions(1).Font
                         .ThemeColor = xlThemeColorDark1
                         .TintAndShade = 0
                     End With
                     .FormatConditions(1).Borders(xlLeft).LineStyle = xlNone
                     .FormatConditions(1).Borders(xlRight).LineStyle = xlNone
                     .FormatConditions(1).Borders(xlBottom).LineStyle = xlNone
                     .FormatConditions(1).StopIfTrue = False
                    End With
                   
                Next
                   
                    With .Spinners.Add(.Cells(1, 1).Left, .Cells(1, 1).Top, 18, .Cells(1, 1).Height)
                        .Value = 2020
                        .Min = 2015
                        .Max = 2040
                        .SmallChange = 1
                        .LinkedCell = "$A$1"
                        .Display3DShading = False
                    End With
                    With .Spinners.Add(.Cells(1, 2).Left, .Cells(1, 1).Top, 18, .Cells(1, 1).Height)
                        .Value = 11
                        .Min = 1
                        .Max = 12
                        .SmallChange = 1
                        .LinkedCell = "$B$1"
                        .Display3DShading = False
                    End With
                    '''''''''''''''''
                            Application.PrintCommunication = False
                            With .PageSetup
                                .PrintTitleRows = ""
                                .PrintTitleColumns = ""
                            End With
                            Application.PrintCommunication = True
                            .PageSetup.PrintArea = "$A$3:$E$26"
                            Application.PrintCommunication = False
                            With .PageSetup
                                .RightFooter = "&""-,Bold Italic""&K7030A0jonwondon"
                                .LeftMargin = 30
                                .RightMargin = 30
                                .TopMargin = 60
                                .BottomMargin = 30
                                .HeaderMargin = 40
                                .FooterMargin = 25
                                .CenterHorizontally = True
                                .CenterVertically = False
                                .Orientation = xlPortrait
                                .Zoom = False
                                .FitToPagesWide = 1
                                .FitToPagesTall = 1
                            End With
                            Application.PrintCommunication = True
            End With ' WS
   
    'Create Module For Ribbons Controls
    MdlFile = DefltPath & "RibbonsCnotrols.bas"
    AddControlsModule MdlFile
    'Import Module File
    .VBProject.VBComponents.Import MdlFile
    Kill MdlFile
    '''''''''''''''''
    On Error Resume Next
    .SaveAs Filename:=FullName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    .Close
    On Error GoTo 0
   
End With ' WB
       
        ' Now start to Add Custon Ribbon Controls
        'Convert Excel File to Zip File
        If Dir(ZipFileName) <> "" Then Kill ZipFileName ' Delete Existing Zip File
        Name FullName As ZipFileName

       
        ' Move Files into New Created Folder
        Set fso = CreateObject("scripting.filesystemobject")
        On Error Resume Next
        fso.deletefolder FolderName
       
        '1- Create Folder
        MkDir FolderName
        On Error GoTo 0
        Application.Wait (Now + TimeValue("0:00:01"))
        Set wShApp = CreateObject("Shell.Application")
       
        '2-Transfere File
        Do Until wShApp.Namespace(ZipFileName).Items.Count = 0
        wShApp.Namespace(FolderName).MoveHere wShApp.Namespace(ZipFileName).Items
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
       
        ' Create Custom Folder For Custom XML File
        CustomUIFolder = FolderName & "\customUI\"
        MkDir CustomUIFolder
       
        'Place "customUI14XML" into CustomUI Folder
        customUI14xml CustomUIFolder & "customUI14.XML"
       
        ' Update _rels\.rels XML File
        Open FolderName & "\_rels\.rels" For Input As TextFile: FileContent = Input(LOF(TextFile), TextFile): Close TextFile
        TXT1 = "</Relationships>"
        TXT2 = "<Relationship Id=""cuID14"" Type=""http://schemas.microsoft.com/office/2007/relationships/ui/extensibility"" Target=""customUI/customUI14.xml""/>"
        FileContent = Replace(FileContent, TXT1, TXT2 & TXT1)
        Open FolderName & "\_rels\.rels" For Output As TextFile: Print #TextFile, FileContent: Close TextFile
   
        'Place "customUI14XML" into CustomUI Folder
        imageFolder = CustomUIFolder & "images\"
        MkDir imageFolder
        'Load PDF Image
        PDFImage imageFolder & "PDF.png"
       
        'Create  _rels Folder For Images
        relsFolder = CustomUIFolder & "_rels\"
        MkDir relsFolder
        Set imageFolder = fso.GetFolder(imageFolder)
        TXT = ""
        Extn = ""
        TXT = "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & vbNewLine
        TXT = TXT & "<Relationships xmlns=""http://schemas.openxmlformats.org/package/2006/relationships"">" & vbNewLine
 
        'Linked Images into custom rels Folder
        For Each file In imageFolder.Files
            TXT = TXT & "<Relationship Id=""" & Replace(file.Name, ".", "_") & """ Type=""http://schemas.openxmlformats.org/officeDocument/2006/relationships/image"" Target=""" & Replace(Split(file.Path, "customUI\")(1), "\", "/") & """/>" & vbNewLine
              If InStr(1, Extn, Split(file.Name, ".")(1)) = 0 Then Extn = Extn & "<Default Extension=""" & Split(file.Name, ".")(1) & """ ContentType=""image/." & Split(file.Name, ".")(1) & """/>"
        Next
        TXT = TXT & "</Relationships>"
        ' Write Linked Image XML File Into relsFolder
        Open relsFolder & "customUI14.xml.rels" For Output As TextFile: Print #TextFile, TXT: Close TextFile
   
        'Update [Content_Types].xml
        Open FolderName & "\[Content_Types].xml" For Input As TextFile: FileContent = Input(LOF(TextFile), TextFile): Close TextFile
        TXT1 = "<Types xmlns=""http://schemas.openxmlformats.org/package/2006/content-types"">"
        TXT2 = Extn
        FileContent = Replace(FileContent, TXT1, TXT1 & TXT2)
        Open FolderName & "\[Content_Types].xml" For Output As TextFile: Print #TextFile, FileContent: Close TextFile
       
        ' Now All Custom File and Folder Complete, So will Zip them
        Application.Wait (Now + TimeValue("0:00:01"))
        On Error Resume Next
        Do Until wShApp.Namespace(FolderName).Items.Count = 0
        wShApp.Namespace(ZipFileName).MoveHere wShApp.Namespace(FolderName).Items ' should be MoveHere Not CopyHere
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
       
        ' Back Convert Zip File to Excel Work Book
        Name ZipFileName As FullName
       
        ' Clead Temp Folder
        Set fso = CreateObject("scripting.filesystemobject")
        On Error Resume Next
        fso.deletefolder FolderName
       
        'Desktop Refresh
        Dim objTMP As Object
        Set objTMP = CreateObject("Shell.Application").Namespace(0)
        With objTMP
            .Self.InvokeVerb "R&efresh"
        End With
        Set objTMP = Nothing
        ''''''''''''''
       
        Set MyFile = Workbooks.Open(FullName)
        MyFile.Activate
       
        Application.WindowState = xlMaximized
        ActiveWindow.WindowState = xlMaximized
        Application.ScreenUpdating = True
End Sub

Public Function AddControlsModule(FilePath As String) As String

Dim TXT As String
    TXT = TXT & "Attribute VB_Name = ""RibbonsCnotrols""" & vbNewLine
TXT = TXT & "Public SignRbnUI As IRibbonUI" & vbNewLine
   TXT = TXT & "Public TXTBOX1 As String" & vbNewLine
   TXT = TXT & "Public TXTBOX2 As String" & vbNewLine
   TXT = TXT & "Public WB As Workbook" & vbNewLine
   TXT = TXT & "Public ws As Worksheet" & vbNewLine
   TXT = TXT & "'Callback for customUI.onLoad" & vbNewLine
   TXT = TXT & "Sub SignRbn(ribbon As IRibbonUI)" & vbNewLine
   TXT = TXT & "Set SignRbnUI = ribbon" & vbNewLine
   TXT = TXT & "TXTBOX1 = Cells(1, 1)" & vbNewLine
   TXT = TXT & "TXTBOX2 = Cells(1, 2)" & vbNewLine
   TXT = TXT & "End Sub" & vbNewLine
   TXT = TXT & "'Callback for Combobox1 getItemCount" & vbNewLine
   TXT = TXT & "Sub Cmbbox_getItemCount(control As IRibbonControl, ByRef returnedVal)" & vbNewLine
   TXT = TXT & "    " & vbNewLine
   TXT = TXT & "    If control.ID = ""Combobox1"" Then" & vbNewLine
   TXT = TXT & "        returnedVal = 11" & vbNewLine
   TXT = TXT & "    ElseIf control.ID = ""Combobox1"" Then" & vbNewLine
   TXT = TXT & "        returnedVal = 12" & vbNewLine
   TXT = TXT & "    End If" & vbNewLine
   TXT = TXT & "    " & vbNewLine
   TXT = TXT & "End Sub" & vbNewLine
   TXT = TXT & "'Callback for Combobox1 getItemLabel" & vbNewLine
   TXT = TXT & "Sub Cmbbox_getItemLabel(control As IRibbonControl, index As Integer, ByRef returnedVal)" & vbNewLine
   TXT = TXT & "    " & vbNewLine
   TXT = TXT & "    If control.ID = ""Combobox1"" Then" & vbNewLine
   TXT = TXT & "        returnedVal = index + 2019" & vbNewLine
   TXT = TXT & "    ElseIf control.ID = ""Combobox2"" Then" & vbNewLine
   TXT = TXT & "        returnedVal = index + 1" & vbNewLine
   TXT = TXT & "    End If" & vbNewLine
   TXT = TXT & "End Sub" & vbNewLine
   TXT = TXT & "'Callback for Combobox1 getText" & vbNewLine
   TXT = TXT & "Sub Cmbbox_getText(control As IRibbonControl, ByRef returnedVal)" & vbNewLine
   TXT = TXT & "    " & vbNewLine
   TXT = TXT & "    If control.ID = ""Combobox1"" Then" & vbNewLine
   TXT = TXT & "        returnedVal = TXTBOX1" & vbNewLine
   TXT = TXT & "    ElseIf control.ID = ""Combobox2"" Then" & vbNewLine
   TXT = TXT & "        returnedVal = TXTBOX2" & vbNewLine
   TXT = TXT & "    End If" & vbNewLine
   TXT = TXT & "End Sub" & vbNewLine
   TXT = TXT & "'Callback for Combobox1 onChange" & vbNewLine
   TXT = TXT & "Sub Cmbbox_onChange(control As IRibbonControl, text As String)" & vbNewLine
   TXT = TXT & "    If control.ID = ""Combobox1"" Then" & vbNewLine
   TXT = TXT & "        TXTBOX1 = text" & vbNewLine
   TXT = TXT & "         Cells(1, 1) = TXTBOX1" & vbNewLine
   TXT = TXT & "    ElseIf control.ID = ""Combobox2"" Then" & vbNewLine
   TXT = TXT & "        TXTBOX2 = text" & vbNewLine
   TXT = TXT & "         Cells(1, 2) = TXTBOX2" & vbNewLine
   TXT = TXT & "    End If" & vbNewLine
   TXT = TXT & "SignRbnUI.Invalidate" & vbNewLine
   TXT = TXT & "End Sub" & vbNewLine
   TXT = TXT & "'Callback for Button1 onAction" & vbNewLine
   TXT = TXT & "Sub Bttn_onAction(control As IRibbonControl)" & vbNewLine
   TXT = TXT & "    Set WB = ThisWorkbook: Set ws = WB.Worksheets(1)" & vbNewLine
   TXT = TXT & "    If control.ID = ""Button1"" Then" & vbNewLine
   TXT = TXT & "        TXTBOX1 = TXTBOX1 + 1" & vbNewLine
   TXT = TXT & "         Cells(1, 1) = TXTBOX1" & vbNewLine
   TXT = TXT & "    ElseIf control.ID = ""Button2"" Then" & vbNewLine
   TXT = TXT & "        TXTBOX1 = TXTBOX1 - 1" & vbNewLine
   TXT = TXT & "         Cells(1, 1) = TXTBOX1" & vbNewLine
   TXT = TXT & "    ElseIf control.ID = ""Button3"" Then" & vbNewLine
   TXT = TXT & "        TXTBOX2 = TXTBOX2 + 1" & vbNewLine
   TXT = TXT & "        " & vbNewLine
   TXT = TXT & "        TXTBOX2 = ((TXTBOX2 - 1) Mod 12) + 1" & vbNewLine
   TXT = TXT & "         Cells(1, 2) = TXTBOX2" & vbNewLine
   TXT = TXT & "    ElseIf control.ID = ""Button4"" Then" & vbNewLine
   TXT = TXT & "    " & vbNewLine
   TXT = TXT & "        TXTBOX2 = TXTBOX2 - 1" & vbNewLine
   TXT = TXT & "        If TXTBOX2 < 1 Then TXTBOX2 = 12" & vbNewLine
   TXT = TXT & "        TXTBOX2 = (((TXTBOX2 - 1) Mod 12) + 1)" & vbNewLine
   TXT = TXT & "         Cells(1, 2) = TXTBOX2" & vbNewLine
   TXT = TXT & "    ElseIf control.ID = ""Button5"" Then" & vbNewLine
   TXT = TXT & "    Sxport_To_Word" & vbNewLine
   TXT = TXT & "    ElseIf control.ID = ""Button6"" Then" & vbNewLine
   TXT = TXT & "    ToPDF" & vbNewLine
   TXT = TXT & "    ElseIf control.ID = ""Button7"" Then" & vbNewLine
   TXT = TXT & "    " & vbNewLine
   TXT = TXT & "    ws.PrintOut Copies:=1, Collate:=True, _" & vbNewLine
   TXT = TXT & "        IgnorePrintAreas:=False" & vbNewLine
   TXT = TXT & "    End If" & vbNewLine
   TXT = TXT & "SignRbnUI.Invalidate" & vbNewLine
   TXT = TXT & "End Sub" & vbNewLine
   TXT = TXT & "Public Sub Sxport_To_Word()" & vbNewLine
   TXT = TXT & "Dim WB As Workbook" & vbNewLine
   TXT = TXT & "Dim ws As Worksheet" & vbNewLine
   TXT = TXT & "Dim wrdApp As Object" & vbNewLine
   TXT = TXT & "Dim WrdDoc As Object" & vbNewLine
   TXT = TXT & "Dim OpnWrd As Object" & vbNewLine
   TXT = TXT & "Dim myRange  As Object" & vbNewLine
   TXT = TXT & "Dim Tbl As Object" & vbNewLine
   TXT = TXT & "Dim R As Long" & vbNewLine
   TXT = TXT & "Set WB = ThisWorkbook" & vbNewLine
   TXT = TXT & "Set ws = WB.Worksheets(1) '""Sheet1"" or any Name ""Sheet_Name""" & vbNewLine
   TXT = TXT & "Dim WrdPath As String" & vbNewLine
   TXT = TXT & "Path = WB.Path" & vbNewLine
   TXT = TXT & "WrdPath = Path & ""\"" & ""Monthly Signin Sheet.docx""" & vbNewLine
   TXT = TXT & "    On Error Resume Next" & vbNewLine
   TXT = TXT & "    Set OpnWrd = GetObject(, ""Word.Application"")" & vbNewLine
   TXT = TXT & "    Set OpnWrd = GetObject(WrdPath)" & vbNewLine
   TXT = TXT & "    If Not OpnWrd Is Nothing Then" & vbNewLine
   TXT = TXT & "    OpnWrd.Close False" & vbNewLine
   TXT = TXT & "    OpnWrd.Quit" & vbNewLine
   TXT = TXT & "    End If" & vbNewLine
   TXT = TXT & "    If Len(Dir(WrdPath)) <> 0 Then Kill WrdPath" & vbNewLine
   TXT = TXT & "    On Error GoTo 0" & vbNewLine
   TXT = TXT & "Set wrdApp = CreateObject(""Word.Application"")" & vbNewLine
   TXT = TXT & "Set WrdDoc = wrdApp.Documents.Add" & vbNewLine
   TXT = TXT & "wrdApp.Visible = True" & vbNewLine
   TXT = TXT & "WrdDoc.SaveAs WrdPath" & vbNewLine
   TXT = TXT & "'do what" & vbNewLine
   TXT = TXT & "'add table" & vbNewLine
   TXT = TXT & "Set myRange = WrdDoc.Range(0, 0)" & vbNewLine
   TXT = TXT & "'cop from excel" & vbNewLine
   TXT = TXT & "CntRw = 0" & vbNewLine
   TXT = TXT & "CntRw = [=AGGREGATE(14,6,(ROW($A$4:$A$28)-ROW($A$4)+1)/--(MONTH(TRIM(MID($A$4:$A$28,FIND(CHAR(10),$A$4:$A$28,1)+2,10)))=$B$1),1)]" & vbNewLine
   TXT = TXT & "ws.Cells(3, 1).Resize(CntRw + 1, 5).Copy" & vbNewLine
   TXT = TXT & "With wrdApp" & vbNewLine
   TXT = TXT & "        With .Selection" & vbNewLine
   TXT = TXT & "            .Paste" & vbNewLine
   TXT = TXT & "             " & vbNewLine
   TXT = TXT & "        Set Tbl = .Tables(1)" & vbNewLine
   TXT = TXT & "            With Tbl" & vbNewLine
   TXT = TXT & "                .Rows.Alignment = 1 'wdAlignRowCenter" & vbNewLine
   TXT = TXT & "                .Rows.HeightRule = 1' wdRowHeightAtLeast" & vbNewLine
   TXT = TXT & "                .Rows.Height = 0" & vbNewLine
   TXT = TXT & "                " & vbNewLine
   TXT = TXT & "                .Range.ParagraphFormat.LineSpacing = 13" & vbNewLine
   TXT = TXT & "                .Range.ParagraphFormat.SpaceBefore = 0" & vbNewLine
   TXT = TXT & "                .Range.ParagraphFormat.SpaceAfter = 0" & vbNewLine
   TXT = TXT & "                .Cell(1, 1).Range.ParagraphFormat.SpaceBefore = 6" & vbNewLine
   TXT = TXT & "                .Cell(1, 1).Range.ParagraphFormat.SpaceAfter = 6" & vbNewLine
   TXT = TXT & "            " & vbNewLine
   TXT = TXT & "                .Range.ParagraphFormat.Alignment = 1' wdAlignParagraphCenter" & vbNewLine
   TXT = TXT & "                .Range.Cells.VerticalAlignment = 1' wdCellAlignVerticalCenter" & vbNewLine
   TXT = TXT & "                " & vbNewLine
   TXT = TXT & "                .Columns(1).Cells.VerticalAlignment = wdCellAlignVerticalCenter" & vbNewLine
   TXT = TXT & "                '.Columns(1).Cells.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft '<<<<<< Not working>>>>> So select One of below" & vbNewLine
   TXT = TXT & "                " & vbNewLine
   TXT = TXT & "                '''''''''''''''''''''''''''''    '''''''''''''''''''''''''''''" & vbNewLine
   TXT = TXT & "                'For Each C In .Columns(1).Cells" & vbNewLine
   TXT = TXT & "                'C.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft'<<<<<< working Well>>>>>" & vbNewLine
   TXT = TXT & "               ' Next" & vbNewLine
   TXT = TXT & "               " & vbNewLine
   TXT = TXT & "                'or" & vbNewLine
   TXT = TXT & "                For R = 2 To .Columns(1).Cells.Count" & vbNewLine
   TXT = TXT & "                .Cell(R, 1).Range.ParagraphFormat.Alignment = 0'wdAlignParagraphLeft" & vbNewLine
   TXT = TXT & "                Next" & vbNewLine
   TXT = TXT & "                '''''''''''''''''''''''''''''    '''''''''''''''''''''''''''''" & vbNewLine
   TXT = TXT & "            End With ' Tbl" & vbNewLine
   TXT = TXT & "            With .PageSetup" & vbNewLine
   TXT = TXT & "                .TopMargin = 36" & vbNewLine
   TXT = TXT & "                .BottomMargin = 36" & vbNewLine
   TXT = TXT & "                .LeftMargin = 36" & vbNewLine
   TXT = TXT & "                .RightMargin = 36" & vbNewLine
   TXT = TXT & "                .Gutter = 0" & vbNewLine
   TXT = TXT & "                .HeaderDistance = 36" & vbNewLine
   TXT = TXT & "                .FooterDistance = 36" & vbNewLine
   TXT = TXT & "            End With '.PageSetup" & vbNewLine
   TXT = TXT & "            " & vbNewLine
   TXT = TXT & "            " & vbNewLine
   TXT = TXT & "        End With '.Selection" & vbNewLine
   TXT = TXT & "        " & vbNewLine
   TXT = TXT & "        .Activate" & vbNewLine
   TXT = TXT & "End With ' wrdApp" & vbNewLine
   TXT = TXT & "'WrdDoc.Close True" & vbNewLine
   TXT = TXT & "'wrdApp.Quit" & vbNewLine
   TXT = TXT & "Application.CutCopyMode = False" & vbNewLine
   TXT = TXT & "Set WrdDoc = Nothing" & vbNewLine
   TXT = TXT & "Set wrdApp = Nothing" & vbNewLine
   TXT = TXT & "End Sub" & vbNewLine
   TXT = TXT & "Public Sub ToPDF()" & vbNewLine
   TXT = TXT & "Dim PDFFileFullName  As String" & vbNewLine
   TXT = TXT & "    Set WB = ThisWorkbook: Set ws = WB.Worksheets(1)" & vbNewLine
   TXT = TXT & "    " & vbNewLine
   TXT = TXT & "    Path = Environ$(""USERPROFILE"") & ""\Desktop\""" & vbNewLine
   TXT = TXT & "    PDFFileFullName = Path & Split(WB.Name, ""."")(0) & "".PDF""" & vbNewLine
   TXT = TXT & "   " & vbNewLine
   TXT = TXT & "   ChDir Path: ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFileFullName, Quality:=xlQualityStandard, _" & vbNewLine
   TXT = TXT & "              IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True" & vbNewLine
   TXT = TXT & "              " & vbNewLine
   TXT = TXT & "End Sub" & vbNewLine
 
   AddControlsModule = TXT
Open FilePath For Binary As #1: Put #1, 1, AddControlsModule: Close #1

End Function


Public Function customUI14xml(FilePath As String) As String

Dim TXT As String
Dim TextFile As Integer         '
TextFile = FreeFile             '

TXT = TXT & "<!--RibbonX Visual Designer (64-bit) 2.50 for Microsoft Excel CustomUI14 . XML Code produced on 2020/10/24-->" & vbNewLine
   TXT = TXT & "<customUI " & vbNewLine
   TXT = TXT & "    xmlns=""http://schemas.microsoft.com/office/2009/07/customui""" & vbNewLine
   TXT = TXT & "    onLoad=""SignRbn"">" & vbNewLine
   TXT = TXT & "    <ribbon >" & vbNewLine
   TXT = TXT & "        <tabs >" & vbNewLine
   TXT = TXT & "            <tab " & vbNewLine
   TXT = TXT & "                id=""Tab1""" & vbNewLine
   TXT = TXT & "                insertBeforeMso=""TabHome""" & vbNewLine
   TXT = TXT & "                label=""Parent Signature"">" & vbNewLine
   TXT = TXT & "                <group  id=""Group1"" >" & vbNewLine
   TXT = TXT & "                    <box " & vbNewLine
   TXT = TXT & "                        boxStyle=""vertical""" & vbNewLine
   TXT = TXT & "                        id=""Box3"">" & vbNewLine
   TXT = TXT & "                        <box " & vbNewLine
   TXT = TXT & "                            boxStyle=""horizontal""" & vbNewLine
   TXT = TXT & "                            id=""Box1"">" & vbNewLine
   TXT = TXT & "                            <comboBox " & vbNewLine
   TXT = TXT & "                                id=""Combobox1""" & vbNewLine
   TXT = TXT & "                                getItemCount=""Cmbbox_getItemCount""" & vbNewLine
   TXT = TXT & "                                getItemLabel=""Cmbbox_getItemLabel""" & vbNewLine
   TXT = TXT & "                                getText=""Cmbbox_getText""" & vbNewLine
   TXT = TXT & "                                onChange=""Cmbbox_onChange""/>" & vbNewLine
   TXT = TXT & "                            <button " & vbNewLine
   TXT = TXT & "                                id=""Button1""" & vbNewLine
   TXT = TXT & "                                imageMso=""CatalogMergeGoToPreviousRecord""" & vbNewLine
   TXT = TXT & "                                onAction=""Bttn_onAction""/>" & vbNewLine
   TXT = TXT & "                            <button " & vbNewLine
   TXT = TXT & "                                id=""Button2""" & vbNewLine
   TXT = TXT & "                                imageMso=""CatalogMergeGoToNextRecord""" & vbNewLine
   TXT = TXT & "                                onAction=""Bttn_onAction""/>" & vbNewLine
   TXT = TXT & "                        </box >" & vbNewLine
   TXT = TXT & "                        <box " & vbNewLine
   TXT = TXT & "                            boxStyle=""horizontal""" & vbNewLine
   TXT = TXT & "                            id=""Box2"">" & vbNewLine
   TXT = TXT & "                            <comboBox " & vbNewLine
   TXT = TXT & "                                id=""Combobox2""" & vbNewLine
   TXT = TXT & "                                getItemCount=""Cmbbox_getItemCount""" & vbNewLine
   TXT = TXT & "                                getItemLabel=""Cmbbox_getItemLabel""" & vbNewLine
   TXT = TXT & "                                getText=""Cmbbox_getText""" & vbNewLine
   TXT = TXT & "                                onChange=""Cmbbox_onChange""/>" & vbNewLine
   TXT = TXT & "                            <button " & vbNewLine
   TXT = TXT & "                                id=""Button3""" & vbNewLine
   TXT = TXT & "                                imageMso=""CatalogMergeGoToPreviousRecord""" & vbNewLine
   TXT = TXT & "                                onAction=""Bttn_onAction""/>" & vbNewLine
   TXT = TXT & "                            <button " & vbNewLine
   TXT = TXT & "                                id=""Button4""" & vbNewLine
   TXT = TXT & "                                imageMso=""CatalogMergeGoToNextRecord""" & vbNewLine
   TXT = TXT & "                                onAction=""Bttn_onAction""/>" & vbNewLine
   TXT = TXT & "                        </box >" & vbNewLine
   TXT = TXT & "                    </box >" & vbNewLine
   TXT = TXT & "                    <separator  id=""Separator1"" />" & vbNewLine
   TXT = TXT & "                    <button " & vbNewLine
   TXT = TXT & "                        id=""Button5""" & vbNewLine
   TXT = TXT & "                        imageMso=""ExportWord""" & vbNewLine
   TXT = TXT & "                        label=""Word""" & vbNewLine
   TXT = TXT & "                        size=""large""" & vbNewLine
   TXT = TXT & "                        onAction=""Bttn_onAction""/>" & vbNewLine
   TXT = TXT & "                    <button " & vbNewLine
   TXT = TXT & "                        id=""Button6""" & vbNewLine
   TXT = TXT & "                        image=""PDF_png""" & vbNewLine
   TXT = TXT & "                        label=""PDF""" & vbNewLine
   TXT = TXT & "                        size=""large""" & vbNewLine
   TXT = TXT & "                        onAction=""Bttn_onAction""/>" & vbNewLine
   TXT = TXT & "                    <button " & vbNewLine
   TXT = TXT & "                        id=""Button7""" & vbNewLine
   TXT = TXT & "                        imageMso=""FilePrint""" & vbNewLine
   TXT = TXT & "                        label=""Print""" & vbNewLine
   TXT = TXT & "                        size=""large""" & vbNewLine
   TXT = TXT & "                        onAction=""Bttn_onAction""/>" & vbNewLine
   TXT = TXT & "                </group >" & vbNewLine
   TXT = TXT & "            </tab >" & vbNewLine
   TXT = TXT & "        </tabs >" & vbNewLine
   TXT = TXT & "    </ribbon >" & vbNewLine
   TXT = TXT & "</customUI >" & vbNewLine
customUI14xml = TXT

Open FilePath For Output As TextFile: Print #TextFile, customUI14xml: Close TextFile


End Function
Function PDFImage(FilePath As String) As String

Dim TXT As String
Dim TextFile As Integer         '
TextFile = FreeFile
PDFImage = ""
PDFImage = PDFImage & _
"iVBORw0KGgoAAAANSUhEUgAAADQAAAA1CAYAAAAOJMhOAAAAAXNSR0IArs4c6QAAAARnQU1BAACxjwv8YQUAAAAJcEhZcwAAFuoAABbqAeWOQxAAAA9TSURBVGhDvVoHkBTVFh1dxIwJIygmzKJlJChomQPmgInSb04o5oxi/savFsJHgSWKJPmiWGp9CQqiZZZdNiiwS2ZzmJ6ZDuef83re" & _
"0js7G7X+q7rV092v7z3n3fvuvW8hpjFq1Kgt5s+ff2V+fv6/CwsLZ1JmFBUVfVhQUPBBm6SwMJRs7/5mKS4ubvhNnFN5P/6nn356fMqUKQeRymaxsWPHbvXDDz+MS6VS6PDwfcDzgCBIP/j/j5KSkrVTp07tE5s5c+blZWVlqK2tRU1NDerq6lBfX29Ev/XcPnMcB4lEAslkEq7rwiMBf/16" & _
"BK+/DlxzDTBxIjghbaJ9I5AuLozHhZFu2ZCteDzeCEtVVZWRiooKCLdkw4YN5v2CBQt+jc2dO3dUeXk5KisrzUMLWlerTKLfeiZDKZEhCJ+KgjvuALp1A/r3B3r2BF59NfRYB0aUlCJGtqI4hE+LLkLCGyVVWlqKn3/+GbE5c+ZMFMPq6mrzkV39KClLxnpHhAQ5WLwYOO444L33QkTDhwMn" & _
"nAD8+GN434EhUtZLIpXpJRGypERIzpCsXr0a3333HWKzZ8/OFSFN0ocGcHp1rDJLyL5zadAQWrQI6NcvDDUNETzlFOCtt8L7DgzrpSihqJcUdlp86yVLaM2aNU0JaQX0oVWS6aEoIbP9i4qACy8EHnnEgMGffwLXXgsMGSJk4bMODJGyhGSz3YTWrVtnJkRJWZESKbThJkMKCQOX8zFsGHD6" & _
"6aD/QUvA0KHAVVeBCg24joxo2NlIEQZLyJKyhBR6TQjphSWlD0RMCqx3pNR4J0pI44svgOOPB3Jzw3vtI3mNMd3RkW0fWS8JV5SQyEjWrl0bEpo1a1YDIU0QKU2OekvKbLgZMtFwYtrGLbcAl1wCTgbefhs46yyguDg9of2jNULCZsMuSmjJkiUhofUEpYeWUNRLUmLDLSshjU8+CbPdpEmh" & _
"p0Ro6dL0y44NS0o2o/uoVUIsrFkJ6cNMQg3hlkmIdcDsnfPOA55/HrjsMrAopF92bLSXkKKsEaFoyFkP2T3UKiENpeyTTwYOOwy48krgl1/SLzo2MgkJgyUkbMLYLCHdZHqo3YS4gnjtNSAnBxgwIEzpf2G0RMh6KSuh6dOnN7uH2kVIY8WKcP+oW8jPTz/s2OgwoWnTpv19hDRGjgS6dwfe" & _
"fTfswDs4WiLUXMh9++23iLHl/utJwQ49V5br3Bk45hjg66/TL9o/WiOULSm0SEgfZRKS8hYJaR+p2+7dGzjjDODii4Hff0+/bN9orusWJuFrlhBPek2SgiZbL0lJtLDKSzKWdWzcCNx/P3D33WDZDvfTpZeGPV47hvWObMmmFrTNdcgSaq1TkFJLqFkvKbPpoPfEE+H9vHmht66+GigsDJ+1" & _
"YbRGyIac8Dbx0OTJkxsIWS9FCSkxtJnQN98AZ58NjB6dfsDx+edAnz7ARReFXmvDMIRox6U9s39oXxiExSaETELyUKuE9HFmprOkmhBSGI4fD5x2GqBzUnQsXBjuKZ2VZsxo9ZguzTqipChJ2nM4Xxjq5Z1IuAmrcEtEaBHtZiVkwy5KSCvUIiG1P/fcAwwaFB4jMofq0s03h93EO++AMZJ+" & _
"0XhIq5K9/mSTpDDNgC0v6im1lBrariGuKuLMSmjChAm5urEvRCpKKNs+kjQJO25Icy564430g4whD5aUhIe//fYDBg8GPv00PK4rFOXFzz5D8NFH8Cnu7NlweU1Rkmx+He7HOvaHtVw4LVcVcQlrlNBitl+xXA7d6A8NlpD1kt1HlpQISeQhiS9SAkuy0F9+1JyWluoJqCxsUAnMeESJ4sEH" & _
"wxPtPvsA224b9n06Sx17LHDmmaYHDC6/HMEFF8A/5xz4zJI+n3sMV4+h7PKZe8MNqPv4Y1QSWwVx2j+S6ID3Dfdwq4SiXrKkUgw9bVhXtYLYA9Wac88NU7Y8JS8pvM4/Hzj11DBRqGHVuUnH9TffBN5/H3jyyTAEt9kG2HtvBNddB/+tt+DJMzw4JplQEnPnwpk1C4lx45BgjUtqTq9eqJ0+" & _
"HRXcDmXE3ISQbjayhli2ImQ3XhMvKfRIRvHtUjwuQPD44yEogRs4MEwAXEm88AIwbRqYfsJaRL2MV/lv0+C5KRg1CgEXIOBJN+Dx3X/0UbhMMMn58xFnKajjd7WMBoVarXRtvTXiXJgyLu7GNCH91ccQGjNmjCGkP5RYUvKUSElEqCHj0TPaoMpRyeXL4XGVgltvDXs31Zv77gv/pCWj1NOW" & _
"oRItL3sMVW/OHPjDhsG/4goEDDGfWdFTmJFkinaS3H8ppn+PYVr95Zco4yILs7CvWrUqOyFJNPRq6ClDigmgjoad336DS9f7PMQFdD222AIBf3vc3D5Ja09l5L+sQwnF1BuGrcur/GaE98mVK413EhMnIskDY5LZM0kPJm+8Ec6996KG4VhGW/LORuK2hBYysRhCcpf6uaiXonupmu6uZZpN" & _
"vvSSWTWfe8Llavk8JgTc0G5engFjQlD7iqL2yIK2Q7/tc2XJaDegeiNJ8JlN0yZVc36tFpX4qomhkkQqOKeM2ERGuCX6y6khNHr06FyxUy2KkjJeUtipOjP+U1whj+CTzzyD+PffI8VuwBeZSZPMfkrSiE3pAmkBS0TCNptWLBFDRt0A94NtbyR1Etnm8xrOqaJUUsr5rJyLXaZQo0QJLViw"

PDFImage = PDFImage & "APqnlEaEJNZL5fROhYwwawW774561o0agne40X0eD9zHHjMgHIJLEJSARYtvcxIlEiVjCamYKwlp3yrkqxUlihYSKScuYdtIEVbhlpSwxjUQEjul7qiXDCEqqZCBMWPg77knkuyiE4xhpc3U0KGIk3g9V14gbOGVWFLNSZRI1DP22kCGezfa5thCKmzCKKzCLRGh+dx3sZEjR+bqRokhSsp4" & _
"iR+XSyGfx1k4vZNOQor1JjFiBOqotI5kFBbR9iiTWDaJErEkpKORZ1ogI2zWO5bQSiaSeewmYiNGjMgt4Y0SQyYp4yl+XE7lFVRc9csvqGZPVk0Q1QRm07lAWEDxDHLZRO+tWBJ11JNJxPRraSI21KxnLBlhlqxYsQLzvvoKsXdUWDlJG0yi2CyTEq0KpYoGTNoWAe4fpe56hk0D6LQnTDhF" & _
"9kk0AWRKo/1EMRku7TnTWVNv1GPVaaLCUkmipuUhSWG1uFeT1EL9KfjVIUNyfya7ZZxYwEmFJFPE38VcpT8of1LJcipcScUlNCAppayi0dWUNQQgWUtA6yi6rpcQZEti567jb12tHumU7lIumGzJ7gqKMAiLMBUTXxFJFRBrPkktI+7fSGoGk1VsSteuuUvZZ+U9/DDy2MLks4lc9tRTWPb0" & _
"08gfPhzLJM8+i4LnnkMBi1wB25kC1qPCl19GkeSf/0TRK6+giMW26LXXjBTryj3XnBRL0nPNd/qeUixd1CndBS++GNqSTdoWBmHJZ9kQNmHMI9alxKzrr+xS/svMG5uTk5MbZ7V3tt8eTpcucHbcEYmdd4bTtSuc3XaDs8cecPbaC063bnDYQDo9esDZf384Bx4Ip2dPOAcfDOfQQ+Gwc3YO" & _
"PzwU+/vII+EwIzaSI47YNMeKvqckDjkk1HnAAXD23Te0JZtsrYx9YREmYjMYd9ghxMxr/XbbIT8WQ+w/nTvnpjbbDP7mm8Pv1Al+587wt9oKAZvNgCQDTg5IMqCCYNddEVBhQMUBSQbq4VifwDmgYnAe+B4EAhI2Pd4uu4RCEGau3hGweU+woF7zPW2ZIwXnGd2ca2zpfqedQgy0EXCOsAmj" & _
"wZqTg4DYUySzjL9js0gowR8uybic5HKyS7YuP3apxKNBj0o9KvdIxGM98mjQJ9iAgKoPOgj5ffrg9wEDkMejQiFXv1LA+a7i6KOR168flvJ5PqXgqKOwju9c6tEhr45eKWb7lMcuPa9/fyyllNNjPr2humdscb7HhTQYiMXgkpCYwbrllvCIXRzyeI3NjBJi6GmCy/bcfMBV87h6HlfI4yob" & _
"xZYYxaeROnbCJTwPlS5bhlXs6Qp4qPvtoYdQTlB1t9+OUqb5kuJirOIx4A/KDxMmoJAEkrSTYCe9mqm2hK1VaWGhudbcdht82ZAtkUkTMWS4wMJksAmjHEDcjQhNJ6GkJdQMKdeSinpLBmkgRdBqKF21Q0wuLtuP8tJSbLj6aqR4QjWHQXbN3qBBcHNzTfr9g0ftjfSQmtwU063HplLnIV+H" & _
"txNP3OQViWyKiLyiyLFkhDGN2RJaymtsaiYhiUiJfSapaAjqSiM6pySYXn1mHp9xXMcuXB1Eihkp9cADSDCtujzJBtQbMIR8kqtmqi4j+CSP1y77yNq330Y5wVbw+yR1Gg9ZGyJD2408EyEjaUyoU6emhCTNecqS0pUgvJtuMoRWjhyJJTxaFHP1U6zk+ttAin2fw3ohYr42MvV6JKzi6fAg" & _
"5553Htx0qH5P7/3IJriSe8qnLRMRFOOZTDLCFsHaiNCUNCE9jE4ykkkqmix49fg8NXgwHBZBnU/WsEDX8wAYcB+IbFLdOIugCEGZkx6ovusu03V4rB/eWWchQTIJtl0JHtoSH3wAl/2ip80ur0hkU/fNkJE0IjS5JUKSKKloBpR3+Dx1/fVw6KEUN7sOez7riEfyhizD0GE112nTIZkV9Ozy" & _
"GTNMaxMMHAiXmdHhfkuOGwdfe0rhJa+ISNqGsanwb4aMpH2EJNlI6cp3AqsTZpKV3mM90+p6ChnNJSGdOgtmzsTXPG78+uWXqNKpld26Lx3s3B2GZ2LsWLNnjK1oiFkyrDfNkZE0IjQpJ2d8koWpRUISKZRiS0qG+Cx1ySVIMlUrrFwREhmJ5nB/pRiCcabjeqZul+cV/847wyxGj8lDqUWL" & _
"4LLNcek9s2iZXpHNbHgiIuwOCf1OiY3ZdtvxcX7ktYWURAZkSAZFTntJAAVIYLS6WmU9V+1iZlNHITGJRN9r9fVe96xnLuc1eEQ62+CVqKhbcIj/V34fe27XXR9et88+UNgp7WrlWhV5gvO1AOaqe/0mECMEZYTEzXMCM1ctXOZ7q0fvNM/qk2SznSnpeXHuvQ+7d6+P7dely/Hje/UqLWen" & _
"Wq8mlKsdb6twdeP0QJzfxdkZGKEnjLD1iXOhjGT+lth59jvpkC7pzGarOeH8Oiain1iQb+7e/Xn9l9Pjemy//T8eP+KIxRNOOsn/oF+/1OQ+fRLtkr59N0m/fpuuzUnmXEk2va3IFEnfvt47vXuvPqdHj391isVO/h/wGSgTaCG2HgAAAABJRU5ErkJggg=="

Open FilePath For Binary As #1: Put #1, 1, DecodeBase64(PDFImage): Close #1

End Function

Function DecodeBase64(ByVal strData As String) As Byte()

' On Error Resume Next
Dim objXML As Object 'MSXML2.DOMDocument
Dim objNode As Object 'MSXML2.IXMLDOMElement
'get dom document
Set objXML = CreateObject("MSXML2.DOMDocument")
'create node with type of base 64 and decode
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.Text = strData
DecodeBase64 = objNode.nodeTypedValue
'clean up
Set objNode = Nothing
Set objXML = Nothing

End Function

Auto-Create a monthly Sign in sheet for preschool students

jonwondon

New Member

Dave Patton

Well-known Member

Excel Facts

Dossfm0q

Banned User

My Aswer Is This

Well-known Member

Dossfm0q

Banned User

Attachments

Similar threads

Forum statistics

Share this page

Auto-Create a monthly Sign in sheet for preschool students

jonwondon

New Member

Dave Patton

Well-known Member

Excel Facts

Dossfm0q

Banned User

My Aswer Is This

Well-known Member

Dossfm0q

Banned User

Attachments

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock