Consulting

Results 1 to 2 of 2

Thread: Inserting Calendar Month (requires borders and month name?)

  1. #1
    VBAX Contributor
    Joined
    Dec 2018
    Location
    South London
    Posts
    115
    Location

    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.

    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
    Last edited by Paul_Hossler; 04-06-2020 at 06:59 PM.

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

        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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •