Month appears in the slide heading's placeholder by accident

[StarPig]

Hi VBA Express

I have the below code, but when I run it on the attached slide, the month and year appears in the placeholder (heading) of the slide, even replacing any heading that was there.

Is there a way so the month and year only stay within the table?

Thank you :)




Sub Calendar()
Dim strText As String
Dim osld As Slide
Set osld = ActiveWindow.Selection.SlideRange(1)
With osld.Shapes.AddTable(7, 7)
With .Table.Cell(1, 1)
With .Borders(ppBorderTop)
.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 = 12
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(0, 0, 0)
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(170, 170, 170)
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(225, 225, 225)
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(225, 225, 225)
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
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
End Sub

[June7]

I downloaded your file. Didn't find any code. Had to add module and save as pptm. There were two variables not declared: otbl and Y. Do you have Option Explicit at top of module?

The date gets added to title with this line:
osld.Shapes.Title.TextFrame.TextRange = MonthName(lngM) & " " & lngY

What do you want instead?

[StarPig]

Hi June7

Thanks for replying - I've attached the *.pptm file, sorry I sent the *.pptx :)

Basically, when it inserts the calendar month, I don't want it to change the slide heading's placeholder - even if there's text typed in, it overwrites it with the calendar table's month and year.

I'm amateur, and sorry, I don't now what "Do you have Option Explicit at top of module?" means.

Thank you :)

[Aussiebear]

If you have Option Explicit at the top of your code, it forces you to define your variables, and then helps correct your code.

[June7]

Either modify the line I indicated to set box to something else or delete it or comment it so it does not execute. Your choice.

Review http://fmsinc.com/MicrosoftAccess/modules/options/index.html#:~:text=Option%20Explicit%20is%20automatically%20added%20to%20yo ur%20code,Options%20menu%3A%20Require%20Variable%20Declaration%20Should%20b e%20Checked

[StarPig]

Hi June7, I did both ways, deleted the line, but it still replaced the slide's main heading with the month and year from the table's heading. I went into the Visual Basic Editor and in the tools menu clicked options, editor tab and ticked “Require Variable Declaration”. Unfortunately the heading still drops into the placeholder.
Any suggestion please on the code? I'm not an expert, self-taught, but maybe another code is overwriting your cool suggestions, so the table heading's month/year is repeating in the slide placeholder heading? Thank you, and sorry to be a pain. Best regards, Ray

[John Wilson]

This line is doing what you asked it to! (Adding the date to the Slide Title.)


osld.Shapes.title.TextFrame.TextRange = MonthName(lngM) & " " & lngY

[June7]

Hi June7, I did both ways, deleted the line, but it still replaced the slide's main heading with the month and year from the table's heading. I went into the Visual Basic Editor and in the tools menu clicked options, editor tab and ticked “Require Variable Declaration”. Unfortunately the heading still drops into the placeholder.
Any suggestion please on the code? I'm not an expert, self-taught, but maybe another code is overwriting your cool suggestions, so the table heading's month/year is repeating in the slide placeholder heading? Thank you, and sorry to be a pain. Best regards, Ray

I commented line and Slide Title box no longer gets date. Deleting line should produce same result. As far as I can tell, there is nothing else causing box to get date.

Just setting "Require Variable Declaration" box will not add Option Explicit line to existing module. You will have to manually add by typing.

[StarPig]

Thanks John, I delete it and it still appears as the slide title... I wish it didn't appear at the top of my slide. If there's no placeholder, it doesn't appear. Sorry to be bad at explaining.

[June7]

Did you save the code and the pptm document after edit?

[StarPig]

Hi John and June7, THANK YOU!!! I needed to save the pptm after editing - d'oh. So embarrassing! :thumb
THANKS A MILLION - I only wish I'd asked for help sooner, I've spent hours / days trying to fix it :banghead:. Thanks!

[June7]

Don't feel so bad. I did the same thing, probably because I didn't expect to visit it again. But then I did and when I reopened the pptm, code was as it was before.

[John Wilson]

Glad it worked out. I originally wrote the code for a client and in that the Month / Year was supposed to end up in the slide title. Someone has hacked the code around a lot so here is the original for you.


Sub Calendar()
Dim strText As String
Dim osld As Slide
Dim oshp As Shape
Dim otbl As Table
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 dayName() As String
Set osld = ActiveWindow.Selection.SlideRange(1)
Set oshp = osld.Shapes.AddTable(7, 7)
Set otbl = oshp.Table
With oshp
.Width = 500
.Left = 50
.Top = 150
End With
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
With otbl
With .Cell(1, 1).Shape
With .TextFrame2.TextRange
.Text = MonthName(lngM) & " " & lngY
End With
End With
End With
With otbl
.Cell(Row:=1, Column:=1).Merge _
MergeTo:=.Cell(Row:=1, Column:=7)
End With
dayName = Split("Mon/Tue/Wed/Thu/Fri/Sat/Sun", "/")
For LC = 1 To 7
otbl.Cell(2, LC).Shape.TextFrame.TextRange = dayName(LC - 1)
Next LC
Dim rayDays(1 To 42) As String
Const StartDay As Long = vbMonday
On Error Resume Next
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 8
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 = 12
Next
Next
For LR = 1 To otbl.Columns.Count
For LC = 1 To otbl.Rows.Count
With otbl.Cell(LR, LC).Shape.TextFrame2
.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
.TextRange.Font.Size = 12
.TextRange.Font.Name = "Arial"
.HorizontalAnchor = msoAnchorCenter
Select Case LR
Case Is = 1
.MarginLeft = 0
.MarginRight = 0
.TextRange.Font.Bold = msoTrue
.VerticalAnchor = msoAnchorMiddle
.HorizontalAnchor = msoAnchorCenter
otbl.Cell(LR, LC).Shape.Fill.ForeColor.RGB = RGB(170, 170, 170)
Case Else
.MarginLeft = 5
.MarginRight = 5
.TextRange.Font.Bold = msoFalse
.VerticalAnchor = msoAnchorMiddle
otbl.Cell(LR, LC).Shape.Fill.ForeColor.RGB = RGB(225, 225, 225)
End Select
End With
Next LC
Next LR
If Not otbl.Cell(7, 1).Shape.TextFrame2.HasText Then
otbl.Rows(7).Delete
End If
End Sub

[StarPig]

Thank you :)