Inserting Calendar Month (requires borders and month name?)

Hi John

I've been experimenting with VBA, so it's a bit "messy", but it works okay. It asks you for a year and month, then inserts a table as that month's calendar.

I can't get borders across the top row of Day names. It just goes to the first cell. I've tried duplicating, manipulating, changing numbers, to do avail.

I'd like a black line 1pt above and below the Days, and a black 0.25pt horizontal lines between the dates' rows. Possibly a final border around the calendar month's table? (Sorry I know it's asking a lot, I did try for hours over the weekend and today.)

Also, if possible, ito have the Month's name as the first row, so days go to second? I'm really proud of this achievement so far :)
Thank you.

Code:

---


Sub CalendarMonth()


Dim strText As String
Dim osld As Slide


Set osld = ActiveWindow.Selection.SlideRange(1)
With osld.Shapes.AddTable(6, 7)
With .Table.Cell(1, 1)
With .Borders(ppBorderTop)
.visible = True
.Weight = 1
.ForeColor.RGB = RGB(0, 0, 0)
.DashStyle = msoLineSolid
End With
With .Borders(ppBorderBottom)
.visible = True
.Weight = 1
.ForeColor.RGB = RGB(0, 0, 0)
.DashStyle = msoLineSolid
End With


End With
.Width = 500
.Left = 50
.Top = 150


Dim shp As Shape
For Each shp In ActiveWindow.Selection.SlideRange.Shapes
With shp
If .HasTable Then .Select
End With
Next shp


With ActiveWindow.Selection.ShapeRange(1).Table
    With .Cell(1, 1).Shape
        With .TextFrame2.TextRange
            .Text = "Mon"
        End With
    End With
End With
With ActiveWindow.Selection.ShapeRange(1).Table
    With .Cell(1, 2).Shape
        With .TextFrame2.TextRange
            .Text = "Tue"
        End With
    End With
End With
With ActiveWindow.Selection.ShapeRange(1).Table
    With .Cell(1, 3).Shape
        With .TextFrame2.TextRange
            .Text = "Wed"
        End With
    End With
End With
With ActiveWindow.Selection.ShapeRange(1).Table
    With .Cell(1, 4).Shape
        With .TextFrame2.TextRange
            .Text = "Thu"
        End With
    End With
End With
With ActiveWindow.Selection.ShapeRange(1).Table
    With .Cell(1, 5).Shape
        With .TextFrame2.TextRange
            .Text = "Fri"
        End With
    End With
End With
With ActiveWindow.Selection.ShapeRange(1).Table
    With .Cell(1, 6).Shape
        With .TextFrame2.TextRange
            .Text = "Sat"
        End With
    End With
End With
With ActiveWindow.Selection.ShapeRange(1).Table
    With .Cell(1, 7).Shape
        With .TextFrame2.TextRange
            .Text = "Sun"
        End With
    End With
End With


Dim lngY As Long
Dim lngM As Long
Dim firstDay As Long
Dim lngDayCNT As Long
Dim lastDay As Long
Dim lngDay As Long
Dim lngCount As Long
Dim x As Long
Dim L As Long
Dim LR As Long
Dim LC As Long
Dim rayDays(1 To 42) As String
Const StartDay As Long = vbMonday


On Error Resume Next
Set oTbl = ActiveWindow.Selection.ShapeRange(1).Table
If oTbl Is Nothing Then
MsgBox "Select a table", vbCritical
Exit Sub
End If


lngY = InputBox("Enter Year")
If Not IsNumeric(lngY) Then Exit Sub
lngM = InputBox("Enter Month Number (e.g. 1 = Jan, 2 = Feb... 12 = Dec")
If Not IsNumeric(lngM) Then Exit Sub
If lngM < 1 Or lngM > 12 Then Exit Sub


firstDay = Weekday(DateSerial(lngY, lngM, 1), StartDay)
lngDayCNT = Day(DateSerial(lngY, lngM + 1, 1) - 1)
lastDay = lngDayCNT + firstDay - 1
For L = firstDay To lastDay
lngDay = lngDay + 1
rayDays(L) = lngDay
Next L
For LR = 2 To 7
For LC = 1 To 7
x = x + 1
oTbl.Cell(LR, LC).Shape.TextFrame.TextRange = CStr(rayDays(x))
oTbl.Cell(LR, LC).Shape.TextFrame.TextRange.Font.Size = 10
Next
Next
Set osld = ActiveWindow.Selection.SlideRange(1)
osld.Shapes.title.TextFrame.TextRange = MonthName(lngM) & " " & lngY


Dim B As Long
Set oTbl = ActiveWindow.Selection.ShapeRange(1).Table
oTbl.Parent.Height = 0
For x = 1 To oTbl.Columns.Count
For y = 1 To oTbl.Rows.Count
With oTbl.Cell(y, x)
.Shape.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Shape.TextFrame2.TextRange.Font.Size = 12
.Shape.TextFrame2.TextRange.Font.Name = "Arial"
.Shape.TextFrame2.HorizontalAnchor = msoAnchorCenter
.Shape.Fill.ForeColor.RGB = RGB(220, 220, 220)
Select Case y
Case Is = 1
.Shape.TextFrame2.MarginLeft = 0
.Shape.TextFrame2.MarginRight = 0
.Shape.TextFrame2.TextRange.Font.Bold = msoTrue
.Shape.TextFrame2.VerticalAnchor = msoAnchorMiddle
.Shape.TextFrame2.HorizontalAnchor = msoAnchorCenter
.Shape.Fill.ForeColor.RGB = RGB(220, 220, 220)
Case Is = 2
.Shape.TextFrame2.MarginLeft = 5
.Shape.TextFrame2.MarginRight = 5
.Shape.TextFrame2.TextRange.Font.Bold = msoFalse
.Shape.TextFrame2.VerticalAnchor = msoAnchorMiddle
.Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
Case Else
.Shape.TextFrame2.MarginLeft = 5
.Shape.TextFrame2.MarginRight = 5
.Shape.TextFrame2.TextRange.Font.Bold = msoFalse
.Shape.TextFrame2.VerticalAnchor = msoAnchorMiddle
.Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
End Select
End With
Next 'y
Next 'x


With ActiveWindow.Selection.ShapeRange(1).Table
    With .Cell(1, 1).Shape
        With .TextFrame2.TextRange
End With
End With
End With
With ActiveWindow.Selection.ShapeRange(1).Table
    With .Cell(1, 1).Shape
        With .TextFrame2.TextRange
        End With
End With
End With
End With


End Sub

---

You can add this line before the latest "End With" to add a new row at top of your table:

Code:

---


    ActiveWindow.Selection.ShapeRange(1).Table.Rows.Add 1
   
    With ActiveWindow.Selection.ShapeRange(1).Table
        With .Cell(1, 1).Shape
            With .TextFrame2.TextRange
                .Text = MonthName(lngM) & " " & lngY
            End With
        End With
    End With
   
    With ActiveWindow.Selection.ShapeRange(1).Table
        .Cell(Row:=1, Column:=1).Merge _
        MergeTo:=.Cell(Row:=1, Column:=7)
    End With

---

Then Assign the text you need on it :)

Let me know if it was helpful or not