I'm trying to run through all the shapes of my current visio document using VBA to export some of the strings from it.
It seems easy but I don't know how to get the grouped shapes.
By doing:
Dim vsoShapes AS Visio.Shapes
Dim vsoShape AS Visio.Shape
Set vsoShapes = Application.ActiveWindow.Page.Shapes
For Each vsoShape In vsoShapes
' my code
' my code
Next
I'm going to access all the parent shapes. What I want is accessing the shapes of the children.
Is it possible to access it without ungrouping the grouped (parent) shape?
You can use the Shapes property, i.e. vsoShape.Shapes(1).Name.
Full loop:
Dim vsoShapes AS Visio.Shapes
Dim vsoShape AS Visio.Shape
Dim i As Integer
Dim shapeCount As Integer
Set vsoShapes = Application.ActiveWindow.Page.Shapes
For Each vsoShape In vsoShapes
shapeCount = vsoShape.Shapes.Count
If shapeCount > 1 Then
i = 1
For i = 1 To shapeCount
MsgBox vsoShape.Shapes(i).Text
Next i
End If
Next
Related
I need the get a user defined integer value from the shapes named "CovIBox" on the active page.
What is the correct method?
Private Function GetLastNumber() As Integer
''Need to get the last User Integer property of the shape "CovIBox"
''placed on the active page
Dim oPage As Visio.Page
Dim OColl As Collection
Dim intShapeVal As Integer
Dim IntHighest As Integer
Dim Ival As Integer
Set oPage = Application.ActiveWindow.Page
Set OColl = oPage.Shapes.Name("CovIBox") <----This where it fails
Ival = 0
For Each Shape In vsoCollection
Ival = Shape.CellsU("Prop.InterfaceNo").value
If Ival > IntHighest Then
IntHighest = Ival
End If
Next
Set OColl = Nothing
Set oPage = Nothing
GetLastNumber = IntHighest + 1
End Function
Set OColl = oPage.Shapes.Name("CovIBox)
In Visio each shape have unique name. You mast iterate all shapes per page, check their master name and collect intrested shape to collection
I am trying to create a macro which selects all the tables present in a slide in ppt using vba i tried but the macro is selecting the last table or the table created lastly
here is the code
Sub CheckCoOrdinates()
Dim pptPres As Presentation
Set pptPres = Application.ActivePresentation
Dim pptSlide As Slide
Dim pptShapes As Shape
For Each pptSlide In pptPres.Slides
For Each pptShapes In pptSlide.Shapes
If pptShapes.Type = msoTable Then
Dim i As Integer
For i = 1 To pptSlide.Shapes.Count
pptShapes.Select
pptShapes.Copy
Next
End If
Next
Next
how to create a macro for this
Instead of pptShapes.Select, use pptShapes.Select (False)
The default behavior of Select mimics clicking on a new shape ... the clicked shape is selected, replacing any previous selection. Adding the False parameter makes it behave more like Ctrl+clicking ... the newly selected shape is ADDED to the current selection.
That'll work on a per slide basis but you can't select shapes on multiple slides, so you're going to have to re-write your macro accordingly.
I suspect you'll be better off stepping through each slide, then through each shape on the slide and copy/pasting the tables one at a time.
Dim pptPres As Presentation
Set pptPres = Application.ActivePresentation
Dim xlApp As Object
Dim xlWorkBook As Object
Dim j As Integer
Dim r1 As String
j = 1
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open("D:\Book2.xlsx", True, False)
Dim pptSlide As Slide
Dim pptShapes As Shape
For Each pptSlide In pptPres.Slides
For Each pptShapes In pptSlide.Shapes
If pptShapes.Type = msoTable Then
Dim i As Integer
For i = 1 To pptSlide.Shapes.Count
pptSlide.Select
pptShapes.Select 'msoFalse
pptShapes.Copy
xlWorkBook.sheets(1).Activate
r1 = "A" + CStr(j)
xlWorkBook.sheets(1).Range(r1).PasteSpecial Paste:=xlPasteValues
j = j + 20
Next
End If
Next
Next
'xlWorkBook.Close SaveChanges:=True
Set xlApp = Nothing
Set xlWorkBook = Nothing
I am new to VBA. I am using powerpoint to write a VBA code to add n number of slides and each slide should contain selected picture from the selected path. I have tried following code which is only adding one slide and also a different macro for adding picture to each slide. So my problem is for example i would like to have 40 slides with selected picture to all the slides. Any type of hint would be appreciated.
code to add slide:
Public Sub Add_Example()
Dim pptSlide As Slide
Dim pptLayout As CustomLayout
Set pptLayout = ActivePresentation.Slides(1).CustomLayout
Set pptSlide = ActivePresentation.Slides.AddSlide(2, pptLayout)
End Sub
You can use loops for your goal.
Public Sub Add_Example()
Dim pptSlide as Slide
Dim pptLayout As CustomLayout
Dim SlideCount as Integer
Dim FilePath as String
SlideCount = 40
' add your file path
FilePath = " Your path of file "
Set pptLayout = ActivePresentation.Slides(1).CustomLayout
For i=1 to SlideCount
Set pptSlide = ActivePresentation.Slides.AddSlide(i+1, pptLayout)
pptSlide.Shapes.AddPicture FileName:=FilePath, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=100, Top:=100
Next
End Sub
Im looking for a way to copy the text of the first element of a powerpoint slide into an excel file. I got the following code that prints out the text of the first box:
Sub getText
Dim sld As Slide
Set sld = Application.ActiveWindow.View.Slide
For Each sld In ActivePresentation.Slides
With sld.Shapes(1)
myInput = .TextFrame.TextRange.Text
MsgBox (myInput)
End With
Next
End sub
Now the next step I want to take is to add the data to an excel file. Therefore I try to do the following:
Sub getText()
Dim xlApp As Object
Dim xlWorkBook As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open("~\PROJECTEN\Lopend\office_VA\macroStore.xlsx", True, False)
xlWorkBook.sheets(1).Range("A2").Select
Dim sld As Slide
Set sld = Application.ActiveWindow.View.Slide
For Each sld In ActivePresentation.Slides
With sld.Shapes(1)
myInput = .TextFrame.TextRange.Text
ActiveCell.Text = myInput
End With
Next
End Sub
However when I try it now it get the error: "Object required". Any thoughts on how I should change my code?
Your problem is that you're referencing ActiveCell.Text but VBA has no clue what that is. Also, you haven't declared your myInput variable.
Try this macro, where instead of selecting the cell I'm just assigning the text value to it. Also, if you're writing more than one value your code will keep writing over the same cell. In the code below I've added a couple of lines that will write your text down column A.
Sub getText()
Dim xlApp As Object
Dim xlWorkBook As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open("~\PROJECTEN\Lopend\office_VA\macroStore.xlsx", True, False)
Dim xlWorkSheet As Object ' Create a worksheet object
xlWorkSheet = xlWorkBook.sheets(1) ' Set the sheet you activate to that object
Dim iRow As Long ' Create a variable to store row number
iRow = 1 'Set the first row that you want to start writing data on
Dim sld As Slide
Dim myInput As String
Set sld = Application.ActiveWindow.View.Slide
For Each sld In ActivePresentation.Slides
With sld.Shapes(1)
myInput = .TextFrame.TextRange.Text
xlWorkSheet.Cells(iRow, "A") = myInput 'Using .Cells() you can specify the (row, column) location
iRow = iRow + 1 'increment by one for next line of text
End With
Next
End Sub
Sub Export_as_PDF()
Dim fil As Variant
Dim strfile As String
Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide
Dim SlideCount As Long
Dim ws As Worksheet
Dim Wb As Workbook
Set PPApp = New PowerPoint.Application
PPApp.Presentations.Add
' Slide 1
PPApp.ActivePresentation.Slides.Add PPApp.ActivePresentation.Slides.Count + 1,ppLayoutBlank
Set PPSlide = PPApp.ActivePresentation.Slides (PPApp.ActivePresentation.Slides.Count)
PPApp.ActiveWindow.View.GotoSlide PPApp.ActivePresentation.Slides.Count
Sheet2.Range("F106").Copy
PPApp.Activate
PPApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"
shapecount = PPSlide.Shapes.Count 'Error is here when shapecount = 0
PPSlide.Shapes(shapecount).Select
PPApp.ActiveWindow.Selection.ShapeRange.Left = 15
PPApp.ActiveWindow.Selection.ShapeRange.Top = 15
PPApp.ActiveWindow.Selection.ShapeRange.Width = 100
End Sub
I use the above code (only part of a code is shown) to copy cell ranges from excel and paste as tables in ppt that can be edited. The error occurs in the line 'PPSlide.Shapes(shapecount).Select '
It fails since shapecount = 0 . But if i choose to debug and run the previous line to count shapes, then shapecount is set to 1 and the code runs smooth. I am puzzled. Need help
Based on Marek Stejskal's suggestion, maybe give this a try:
Sub Export_as_PDF()
Dim fil As Variant
Dim strfile As String
Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide
Dim SlideCount As Long
Dim ws As Worksheet
Dim Wb As Workbook
Dim I as integer
Set PPApp = New PowerPoint.Application
PPApp.Presentations.Add
' Slide 1
PPApp.ActivePresentation.Slides.Add _
PPApp.ActivePresentation.Slides.Count + 1,ppLayoutBlank
Set PPSlide = PPApp.ActivePresentation.Slides PPApp.ActivePresentation.Slides.Count)
PPApp.ActiveWindow.View.GotoSlide PPApp.ActivePresentation.Slides.Count
Sheet2.Range("F106").Copy
PPApp.Activate
PPApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"
i = 0
'this loop will wait for .ExecuteMso to do its thing
'while the "i" counter will prevent it from hanging forever
While PPSlide.shapes.count = 0 and i < 1000
do events
i = i + 1
wend
shapecount = PPSlide.Shapes.Count 'Error is here when shapecount = 0
PPSlide.Shapes(shapecount).Select
PPApp.ActiveWindow.Selection.ShapeRange.Left = 15
PPApp.ActiveWindow.Selection.ShapeRange.Top = 15
PPApp.ActiveWindow.Selection.ShapeRange.Width = 100
End Sub
If i < 1000 isn't enough, try increasing it until either
it completes successfully, or
you get tired of waiting for it
This is a tricky one. The problem lies in the way you are pasting the data into PowerPoint. If you were using standard VBA commands, the pasting would run in a sequence, meaning the code would wait until the data is successfully pasted.
By using ExecuteMso you can never be sure what's going on.
Try experimenting with this command
PPApp.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault
and with different DataType values to achieve your goal.