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
Related
I have a table put in a Shape of Word.
I want get a Range in Cell(2,1) at Text ="123"
I try this code , but it can't get a Range of Cell of Table in Shape:
Dim oApp As Object
Dim oShape As Object
Dim oTable As Object
Dim oDoc As Object
Set oApp = CreateObject("Word.Application")
oApp.Visible = True
Set oDocument = oApp.Documents.Open("E:\2022\t1.docx")
Set oShape = oDocument.Shapes(1)
Set oTable = oShape.TextFrame.TextRange.Tables(1)
Dim iStart As Integer
Dim iEnd As Integer
iStart = oTable.Cell(2, 1).Range.Paragraphs(1).Range.Start
iEnd = iStart + 3
oDocument.Range(iStart, iEnd).Text = "ABC"
Notes:
My code will working, if table put in document. But not working when table put in a Shape
How can get a Range of Cell of Table in a Shape?
Assign the range of the cell to a variable first then use SetRange method to adjust the range before doing what you want:
Below will change the text of the first 3 characters in the Cell(2,1) 1st paragraph to "ABC":
Dim rng As Range
Set rng = oTable.Cell(2, 1).Range.Paragraphs(1).Range
rng.SetRange rng.Start, rng.Start + 3
rng.Text = "ABC"
I have the code below which colors bubble chart data points based on the data label text. I'm not sure why I am keeping an "Invalid paramter error"
Edited for more clarity.
The code loops through a spreadsheet where I have data label filter critieria stored(see image attached). It will copy a pre-made bubble graph and color it. variable f loops between variables a and c, and based on the values in between these two variables, the bubble chart will color if it matches. If not, it moves past it. After bubbles are colored, it moves on to the next variation of coloring.
Sub Slide31()
Dim rngx As Range
Dim rngy As Range
Dim rngz As Range
Dim ws3 As Worksheet
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim icnt As Long
Dim lastrow As Long
Dim k As Long
Dim icounter As Long
Dim a As Long
Dim c As Long
Dim b As Long
Dim d As Variant
Dim Chart As ChartObject
Dim PPapp As Object
Dim PPTDoc As PowerPoint.Presentation
Dim PPT As PowerPoint.Application
Dim PPpres As Object
Dim pptSlide As PowerPoint.Slide
Dim ppslide As Object
Dim e As Long
Dim f As Long
Dim filename As String
Dim filename2 As String
Dim x As Variant
Dim y As Variant
Dim z As Variant
Dim ch As Chart
Dim s As Series
Dim iPoint As Long
Dim nPoint As Long
Set ws = Worksheets("Reference")
Set ws1 = Worksheets("Bubbles")
Set ws2 = Worksheets("Slide 31")
Set ws3 = Worksheets("Bubble Reference")
ws2.Activate
'ws2.Range("h:h").NumberFormat = "0.00%"
lastrow = ws2.Cells(Rows.Count, "b").End(xlUp).Row
For icounter = 1 To lastrow
For icnt = 51 To 79
If ws2.Cells(icounter, 2) = ws.Cells(icnt, 3) Then
d = ws.Cells(icnt, 3)
a = icounter + 2
b = icounter + 2
c = icounter + 11
filename = ""
filename2 = ""
ws3.ChartObjects(1).Copy
ws2.Paste
Set ch = ActiveChart
Set s = ch.SeriesCollection(1)
For f = a To c
nPoint = s.Points.Count
For iPoint = 1 To nPoint
If ws2.Cells(f, 8) = s.Points(iPoint).DataLabel.Text Then
s.Points(iPoint).Format.Fill.ForeColor.RGB = RGB(192, 0, 0)
End If
Next iPoint
Next f
End If
Next icnt
Next icounter
Point object doesn't have an Interior property. (Edit: Yes, it actually does even though the Dox and the Intellisense do not seem to expose it).
(Point object reference | Excel Reference)
The specific error you're getting (1004, "Invalid parameter error") is akin to Index Out of Bounds, you're somehow trying to index the Points collection in an invalid way, though I'm not sure how this is possible. You can easily get this error if you try s.Points(0) or s.Points(s.Points.Count+1), for instance.
You could try this alternative approach:
Dim pt as Point
For Each pt in s.Points
If ws2.Cells(f, 8) = pt.DataLabel.Text Then
pt.Format.Fill.ForeColor.RGB = RGB(192, 0, 0)
End If
Next
I have PPTs that are being generated via software that I have no control over. Upon generation, the software puts all text into TextBoxes instead of my Placeholders.
I created a script to move the text from the TextBoxes into the placeholders and this works great; however, I am unable to maintain the links and the lists are always showing as Bulleted despite some being numbers. Basically, if there is a link in the textbox, it should still be a link in the Placeholder. FYI, this script also changes shape 3 on each slide into the Title Placeholder
How can I preserve the formatting when I am moving the text over? I attempted to use pastespecial, but that still was only moving the text into the format of the placeholder.
Sub TextBoxFix()
Dim osld As Slide, oshp As Shape, oTxR As TextRange, SlideIndex As Long, myCount As Integer, numShapesOnSlide As Integer
Dim tempBulletFormat As PowerPoint.PpBulletType
For Each osld In ActivePresentation.Slides
myCount = 1
With ActivePresentation
'For Each oshp In osld.Shapes
osld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
For i = osld.Shapes.Count To 1 Step -1
Set oshp = osld.Shapes(i)
If i = 3 Then
osld.Shapes.Placeholders.Item(1).TextFrame.TextRange = oshp.TextFrame.TextRange.Characters
osld.Shapes.Placeholders.Item(1).Visible = msoTrue
oshp.Delete
ElseIf i > 3 And oshp.Type = msoTextBox Then
oshp.TextFrame.TextRange.Copy
osld.Shapes.Placeholders.Item(2).TextFrame.TextRange.InsertBefore(oshp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = oshp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
oshp.Delete
End If
Next i
End With
Next osld
End Sub
This may have some formatting issues that need to be addressed, but this will insert the hyperlinks that you are looking for. Code is likely not the cleanest, but it works. You will also need to set the vba to break only on unhandled errors, or it will break in the middle of the code. See here.
Class Module - Hyper
Private shp As Shape
Private chrStart As Integer
Private hypAddr As String
Private hypText As String
Private Sub Class_Initialize()
End Sub
Public Sub InitializeWithValues(newShp As Shape, newChrStart As Integer, newHypAddress As String, newHypText As String)
Set shp = newShp
chrStart = newChrStart
hypAddr = newHypAddress
hypText = newHypText
End Sub
Public Function getShape() As Shape
Set getShape = shp
End Function
Public Function getchrStart() As Integer
getchrStart = chrStart
End Function
Public Function getHypAddr() As String
getHypAddr = hypAddr
End Function
Public Function getHypText() As String
getHypText = hypText
End Function
Class Module - hyperColl
Private myCollection As Collection
Private Sub Class_Initialize()
Set myCollection = New Collection
End Sub
Public Sub Add_Item(newHyper As Hyper)
Dim newArray() As Hyper
If Me.Exists(newHyper.getShape().Name) Then
newArray = myCollection(newHyper.getShape().Name)
ReDim Preserve newArray(0 To UBound(newArray) + 1)
Set newArray(UBound(newArray)) = newHyper
myCollection.Remove (newHyper.getShape().Name)
myCollection.Add newArray, newHyper.getShape().Name
Else
ReDim newArray(0)
Set newArray(0) = newHyper
myCollection.Add newArray, newHyper.getShape().Name
End If
End Sub
Public Function GetArray(shapeName As String) As Hyper()
GetArray = myCollection(shapeName)
End Function
Public Function Exists(shapeName As String) As Boolean
Dim myHyper() As Hyper
On Error Resume Next
myHyper = myCollection(shapeName)
On Error GoTo 0
If Err.Number = 5 Then 'Not found in collection
Exists = False
Else
Exists = True
End If
Err.Clear
End Function
Regular Module (Call it whatever you want)
Sub textBoxFix()
Dim sld As Slide
Dim shp As Shape
Dim shp2 As Shape
Dim oHl As Hyperlink
Dim hypAddr As String
Dim hypText As String
Dim hypTextLen As Integer
Dim hypTextStart As Integer
Dim hypShape As Shape
Dim hypCollection As hyperColl
Dim newHyper As Hyper
Dim hypArray() As Hyper
Dim hypToAdd As Hyper
Dim i As Long
Dim j As Long
Dim bolCopy As Boolean
Set sld = ActivePresentation.Slides(1)
sld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
Set hypCollection = New hyperColl 'Set the collection of arrays - 1 for each shape
Set shp = sld.Shapes(1)
For Each oHl In sld.Hyperlinks
If oHl.Type = msoHyperlinkRange Then 'Hyperlink is associated with part of a TextRange, not a whole shape
hypAddr = oHl.Address
hypText = oHl.TextToDisplay
hypTextLen = Len(hypText)
If TypeName(oHl.Parent.Parent) = "TextRange" Then
hypTextStart = oHl.Parent.Parent.start
Set hypShape = oHl.Parent.Parent.Parent.Parent
End If
Set newHyper = New Hyper
newHyper.InitializeWithValues hypShape, hypTextStart, hypAddr, hypText
hypCollection.Add_Item newHyper
End If
Next oHl
For j = sld.Shapes.Count To 1 Step -1
Set shp = sld.Shapes(j)
bolCopy = False
If j = 3 Then
Set shp2 = sld.Shapes.Placeholders.Item(1)
bolCopy = True
ElseIf j > 3 And shp.Type = msoTextBox Then
Set shp2 = sld.Shapes.Placeholders.Item(2)
bolCopy = True
End If
If bolCopy = True Then
shp2.TextFrame.TextRange.InsertBefore(shp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = shp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
If hypCollection.Exists(shp.Name) Then
hypArray = hypCollection.GetArray(shp.Name)
For i = LBound(hypArray) To UBound(hypArray)
Set hypToAdd = hypArray(i)
With shp2.TextFrame.TextRange.Characters(hypToAdd.getchrStart, Len(hypToAdd.getHypText)).ActionSettings.Item(1)
.Action = ppActionHyperlink
.Hyperlink.Address = hypToAdd.getHypAddr
End With
Next i
End If
End If
shp.Delete
Next j
End Sub
I used OpiesDad's code as a starting point, and made some minor modifications. I was getting an error related to the GetArray function when textboxes didn't exist. In addition, I modified the code to run on all slides of the PPT. I also had to make some modifications to the TextBoxFix Sub because the content was being deleted, but wasn't populating in my Placeholders.
See my updates below:
Reused Class Module - Hyper
Removed "On Error GoTo 0" from the Exists Function in hyperColl
Revised TextBoxFix below:
Sub TextBoxFix()
Dim shp As Shape
Dim shp2 As Shape
Dim oHl As Hyperlink
Dim hypAddr As String
Dim hypText As String
Dim hypTextLen As Integer
Dim hypTextStart As Integer
Dim hypShape As Shape
Dim hypCollection As hyperColl
Dim newHyper As Hyper
Dim hypArray() As Hyper
Dim hypToAdd As Hyper
Dim i As Long
Dim j As Long
Dim bolCopy As Boolean
For Each sld In ActivePresentation.Slides
With ActivePresentation
sld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
Set hypCollection = New hyperColl 'Set the collection of arrays - 1 for each shape
Set shp = sld.Shapes(1)
For Each oHl In sld.Hyperlinks
If oHl.Type = msoHyperlinkRange Then 'Hyperlink is associated with part of a TextRange, not a whole shape
hypAddr = oHl.Address
hypText = oHl.TextToDisplay
hypTextLen = Len(hypText)
If TypeName(oHl.Parent.Parent) = "TextRange" Then
hypTextStart = oHl.Parent.Parent.Start
Set hypShape = oHl.Parent.Parent.Parent.Parent
End If
Set newHyper = New Hyper
newHyper.InitializeWithValues hypShape, hypTextStart, hypAddr, hypText
hypCollection.Add_Item newHyper
End If
Next oHl
For j = sld.Shapes.Count To 1 Step -1
Set shp = sld.Shapes(j)
bolCopy = False
If j = 3 Then
sld.Shapes.Placeholders.Item(1).TextFrame.TextRange = shp.TextFrame.TextRange.Characters
sld.Shapes.Placeholders.Item(1).Visible = msoTrue
shp.Delete
ElseIf j > 3 And shp.Type = msoTextBox Then
sld.Shapes.Placeholders.Item(2).TextFrame.TextRange.InsertBefore(shp.TextFrame.TextRange.TrimText).ParagraphFormat.Bullet.Type = shp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
If hypCollection.Exists(shp.Name) Then
hypArray = hypCollection.GetArray(shp.Name)
For i = LBound(hypArray) To UBound(hypArray)
Set hypToAdd = hypArray(i)
With sld.Shapes.Placeholders.Item(2).TextFrame.TextRange.Characters(hypToAdd.getchrStart, Len(hypToAdd.getHypText)).ActionSettings.Item(1)
.Action = ppActionHyperlink
.Hyperlink.Address = hypToAdd.getHypAddr
End With
Next i
End If
shp.Delete
End If
Next j
End With
Next sld
End Sub
I'm getting a type mismatch 13 error in the line that loops through the shapes in a slide. I can see that the oSh is Nothing, but if I .Count the shapes, there are plenty of shapes in the slide. How does this make sense?
Brief code:
Dim oPP As PowerPoint.Presentation
Dim oS As Slide
Dim oSh As Shape
For Each oS In oPP.Slides
For Each oSh In oS.Shapes '<-- this line is the error line
On Error Resume Next
If oSh.Type = 14 _
Or oSh.Type = 1 Then
'do stuff
End If
On Error GoTo 0
Next oSh
Next oS
Full code:
Sub PPLateBinding()
Dim pathString As String
'no reference required
Dim PowerPointApplication As PowerPoint.Application
Dim oPP As PowerPoint.Presentation
Dim oS As Slide
Dim oSh As Object
Dim pText As String
Dim cellDest As Integer
Dim arrBase() As Variant
Dim arrComp() As Variant
ReDim Preserve arrBase(1)
ReDim Preserve arrComp(1)
Dim fd As FileDialog
Dim FileChosen As Integer
Dim FileName As String
Dim iPresentations As Integer
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'use the standard title and filters, but change the
fd.InitialView = msoFileDialogViewList
'allow multiple file selection
fd.AllowMultiSelect = True
FileChosen = fd.Show
If FileChosen = -1 Then
'open each of the files chosen
For iPresentations = 1 To fd.SelectedItems.Count
'On Error Resume Next
Set PowerPointApplication = CreateObject("PowerPoint.Application")
Set oPP = PowerPointApplication.Presentations.Open(fd.SelectedItems(iPresentations))
If Err.Number <> 0 Then
Set oPP = Nothing
End If
If Not (oPP Is Nothing) Then
cellDest = 0
'We assume PP is already open and has an active presentation
For Each oS In oPP.Slides
'Debug.Print oPP.Slides.Count
If oS.Shapes.Count > 0 Then
Debug.Print oS.Shapes.Count
For Each oSh In oS.Shapes
Debug.Print "hey"
On Error Resume Next
If oSh.Type = 14 Or oSh.Type = 1 Then
pText = oSh.TextFrame.TextRange.Text
ReDim Preserve arrBase(UBound(arrBase) + 1)
arrBase(UBound(arrBase)) = pText
'Debug.Print pText
ElseIf (oSh.HasTable) Then
Dim i As Integer
For i = 2 To oSh.Table.Rows.Count
ReDim Preserve arrComp(UBound(arrComp) + 1)
arrComp(UBound(arrComp)) = Replace(oSh.Table.Cell(i, 1).Shape.TextFrame.TextRange.Text, vbLf, "") & ":::" & oSh.Table.Cell(i, 3).Shape.TextFrame.TextRange.Text
Next i
End If
On Error GoTo 0
Next oSh
'x = InputData(arrBase, arrComp)
End If
Next oS
'Debug.Print tbl.Shape.TextFrame.TextRange.Text '.Cell(1, 1).Shape.TextRange.Text
oPP.Close
PowerPointApplication.Quit
Set oPP = Nothing
Set PowerPointApplication = Nothing
End If
Next iPresentations
End If
End Sub
Excel has its own Shape type (which is not the same as PowerPoint.Shape type), so you should change
Dim oSh As Shape
to (for earlier binding)
Dim oSh As PowerPoint.Shape
or (for late binding)
Dim oSh As Object
Also note, if you're going to use powerpoint with late binding (as suggests your function name Sub PPLateBinding()), you should change all types PowerPoint.Something to Object (unless you add reference to powerpoint object model, but in this case I don't see any reason for using late binding).
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