Joel2
09-27-2016, 04:21 PM
I am trying to use an existing Excel 2007 VBA program to open an existing Power Point 2007 slide that has a fixed JPEG map on it, duplicate the slide, then add/remove/update/move objects/shapes (I will call them "Symbols") on that slide, then save and close.
I have hit several road blocks, and recently checked the Power Point 12 Object Library box in Tools>References. This helped get to the point of opening the slide, duplicating it and adding basic shapes, but I can't add/edit text boxes for those shapes. My intent is to create about 5 very basic shapes, 3 short text boxes, then group these into one object as the "symbol" I am trying to place/move on the Power Point slide. I could then change any of the 3 text boxes per symbol, for any of multiple symbols.
Basically imagine a map with square symbols on it indicating locations of groups of people. Text would indicate a group name, number of people, etc.
Here is the code I have written, with "Rem" comments on where I am still getting crashes/errors trying to create and name the text boxes for future updates. Hopefully someone can point out what I am doing wrong. The errors happen in the Make_New_Unit subroutine.
CODE
Sub OpnPwerPt()
Rem Opens a PowerPoint Document from Excel
Path = "C:\Users\Joel\Primary\Core\Games\Hundred Days History\Strategic Move Program"
Set PwrPointApp = CreateObject("PowerPoint.Application")
PwrPointApp.Visible = True
sA = "0400"
Set PwrPointPres = PwrPointApp.Presentations.Open(Path & "\Hundred Days Map Test" & sA & ".pptx")
Rem Create and place units
Make_New_Unit
Move_Object
sA = "0800"
Rem Save and close out Power Point File
PwrPointPres.SaveAs Path & "Hundred Days Map Test" & sA & ".pptx"
PwrPointPres.Close
PwrPointApp.Quit
End Sub
'
Sub Move_Object()
Rem Move Unit Symbols
Rem ActiveWindow.LargeScroll down:=1
PwrPointPres.Slides(2).Shapes("1Brit").Select
Selection.Left = 1
Selection.Top = 180
Rem Application.Goto reference:="home"
Rem Activepresentation.DrawingObjects("1Brit").Select will this work?
'
For t = 1 To 750 Step 10
Selection.Left = t
Next t
End Sub
'
Sub Make_New_Unit()
Rem Create new slide in Power Point Presentation
Set NewSlide = PwrPointPres.Slides(1).Duplicate
Set ActSlide = PwrPointPres.Slides(2)
Rem Create the Basic Piece Parts of a Map Unit Symbol
With ActSlide.Shapes.AddShape(Type:=msoShapeRectangle, Left:=50, Top:=50, Width:=30, Height:=30)
.Name = "UnitBox"
.Fill.ForeColor.RGB = RGB(230, 0, 0) ' Red
.Line.ForeColor.RGB = RGB(0, 0, 0) ' Black
.Line.Weight = 1
End With
With ActSlide.Shapes.AddShape(Type:=msoShapeRectangle, Left:=52, Top:=58, Width:=18, Height:=10)
.Name = "SymbolBox"
.Fill.ForeColor.RGB = RGB(230, 0, 0) ' Red
.Line.ForeColor.RGB = RGB(0, 0, 0) ' Black
.Line.Weight = 1.5
End With
With ActSlide.Shapes.AddLine(BeginX:=70, BeginY:=58, EndX:=52, EndY:=68)
.Name = "CavSlash"
.Line.ForeColor.RGB = RGB(0, 0, 0) ' Black
.Line.Weight = 1.5
End With
With ActSlide.Shapes.AddLine(BeginX:=52, BeginY:=58, EndX:=70, EndY:=68)
.Name = "InfSlash"
.Line.ForeColor.RGB = RGB(0, 0, 0) ' Black
.Line.Weight = 1.5
End With
With ActSlide.Shapes.AddShape(Type:=msoShapeOval, Left:=60, Top:=61, Width:=3, Height:=3)
.Name = "ArtyDot"
.Line.ForeColor.RGB = RGB(0, 0, 0) ' Black
.Line.Weight = 3
End With
'
Rem This fails with error: Run-Time error 448: Named Argument Not Found
ActSlide.Shapes.AddTextbox(Type:=msoTextOrientationHorizontal, Left:=60, Top:=50, _
Width:=20, Height:=12).Name = "UnitSize"
ActSlide.Shapes("UnitSize").TextFrame.TextRange.Text = "XX"
ActSlide.Shapes("UnitSize").TextFrame.Font.Type = "Times New Roman"
ActSlide.Shapes("UnitSize").TextFrame.Font.Size = 10
'
Rem This fails with error: Run-Time error 448: Named Argument Not Found
With ActSlide.Shapes.AddTextbox(Type:=msoTextOrientationHorizontal, Left:=60, Top:=70, Width:=20, Height:=12)
.Name = "UnitStr"
.TextFrame.TextRange.Text = "9000"
.TextFrame.Font.Type = "Times New Roman"
.TextFrame.Font.Size = 10
End With
With ActSlide.Shapes.AddTextbox(Type:=msoTextOrientationVertical, Left:=60, Top:=90, Width:=20, Height:=12)
.Name = "UnitName"
.TextFrame.TextRange.Text = "1Brit/I"
.TextFrame.Font.Type = "Times New Roman"
.TextFrame.Font.Size = 10
End With
Rem How to group a range of shapes into one effective shape not tested yet
Set MyRange = PwrPointPres.Shapes.Range(Array("UnitBox", "SymbolBox", "CavSlash", "InfSlash", "ArtyDot", "UnitSize", "UnitName", "UnitStr"))
Set sUnit = MyRange.Group
sUnit.Name = "1Brit"
End Sub
I have hit several road blocks, and recently checked the Power Point 12 Object Library box in Tools>References. This helped get to the point of opening the slide, duplicating it and adding basic shapes, but I can't add/edit text boxes for those shapes. My intent is to create about 5 very basic shapes, 3 short text boxes, then group these into one object as the "symbol" I am trying to place/move on the Power Point slide. I could then change any of the 3 text boxes per symbol, for any of multiple symbols.
Basically imagine a map with square symbols on it indicating locations of groups of people. Text would indicate a group name, number of people, etc.
Here is the code I have written, with "Rem" comments on where I am still getting crashes/errors trying to create and name the text boxes for future updates. Hopefully someone can point out what I am doing wrong. The errors happen in the Make_New_Unit subroutine.
CODE
Sub OpnPwerPt()
Rem Opens a PowerPoint Document from Excel
Path = "C:\Users\Joel\Primary\Core\Games\Hundred Days History\Strategic Move Program"
Set PwrPointApp = CreateObject("PowerPoint.Application")
PwrPointApp.Visible = True
sA = "0400"
Set PwrPointPres = PwrPointApp.Presentations.Open(Path & "\Hundred Days Map Test" & sA & ".pptx")
Rem Create and place units
Make_New_Unit
Move_Object
sA = "0800"
Rem Save and close out Power Point File
PwrPointPres.SaveAs Path & "Hundred Days Map Test" & sA & ".pptx"
PwrPointPres.Close
PwrPointApp.Quit
End Sub
'
Sub Move_Object()
Rem Move Unit Symbols
Rem ActiveWindow.LargeScroll down:=1
PwrPointPres.Slides(2).Shapes("1Brit").Select
Selection.Left = 1
Selection.Top = 180
Rem Application.Goto reference:="home"
Rem Activepresentation.DrawingObjects("1Brit").Select will this work?
'
For t = 1 To 750 Step 10
Selection.Left = t
Next t
End Sub
'
Sub Make_New_Unit()
Rem Create new slide in Power Point Presentation
Set NewSlide = PwrPointPres.Slides(1).Duplicate
Set ActSlide = PwrPointPres.Slides(2)
Rem Create the Basic Piece Parts of a Map Unit Symbol
With ActSlide.Shapes.AddShape(Type:=msoShapeRectangle, Left:=50, Top:=50, Width:=30, Height:=30)
.Name = "UnitBox"
.Fill.ForeColor.RGB = RGB(230, 0, 0) ' Red
.Line.ForeColor.RGB = RGB(0, 0, 0) ' Black
.Line.Weight = 1
End With
With ActSlide.Shapes.AddShape(Type:=msoShapeRectangle, Left:=52, Top:=58, Width:=18, Height:=10)
.Name = "SymbolBox"
.Fill.ForeColor.RGB = RGB(230, 0, 0) ' Red
.Line.ForeColor.RGB = RGB(0, 0, 0) ' Black
.Line.Weight = 1.5
End With
With ActSlide.Shapes.AddLine(BeginX:=70, BeginY:=58, EndX:=52, EndY:=68)
.Name = "CavSlash"
.Line.ForeColor.RGB = RGB(0, 0, 0) ' Black
.Line.Weight = 1.5
End With
With ActSlide.Shapes.AddLine(BeginX:=52, BeginY:=58, EndX:=70, EndY:=68)
.Name = "InfSlash"
.Line.ForeColor.RGB = RGB(0, 0, 0) ' Black
.Line.Weight = 1.5
End With
With ActSlide.Shapes.AddShape(Type:=msoShapeOval, Left:=60, Top:=61, Width:=3, Height:=3)
.Name = "ArtyDot"
.Line.ForeColor.RGB = RGB(0, 0, 0) ' Black
.Line.Weight = 3
End With
'
Rem This fails with error: Run-Time error 448: Named Argument Not Found
ActSlide.Shapes.AddTextbox(Type:=msoTextOrientationHorizontal, Left:=60, Top:=50, _
Width:=20, Height:=12).Name = "UnitSize"
ActSlide.Shapes("UnitSize").TextFrame.TextRange.Text = "XX"
ActSlide.Shapes("UnitSize").TextFrame.Font.Type = "Times New Roman"
ActSlide.Shapes("UnitSize").TextFrame.Font.Size = 10
'
Rem This fails with error: Run-Time error 448: Named Argument Not Found
With ActSlide.Shapes.AddTextbox(Type:=msoTextOrientationHorizontal, Left:=60, Top:=70, Width:=20, Height:=12)
.Name = "UnitStr"
.TextFrame.TextRange.Text = "9000"
.TextFrame.Font.Type = "Times New Roman"
.TextFrame.Font.Size = 10
End With
With ActSlide.Shapes.AddTextbox(Type:=msoTextOrientationVertical, Left:=60, Top:=90, Width:=20, Height:=12)
.Name = "UnitName"
.TextFrame.TextRange.Text = "1Brit/I"
.TextFrame.Font.Type = "Times New Roman"
.TextFrame.Font.Size = 10
End With
Rem How to group a range of shapes into one effective shape not tested yet
Set MyRange = PwrPointPres.Shapes.Range(Array("UnitBox", "SymbolBox", "CavSlash", "InfSlash", "ArtyDot", "UnitSize", "UnitName", "UnitStr"))
Set sUnit = MyRange.Group
sUnit.Name = "1Brit"
End Sub