I'm tring to split a table if the table overflows the slide. I found some code that I modified slightly.
But when I try to add a row on the new table to copy the header from the original table I get an error.
If I add the line:
``` oTableShape.Table.Rows.Add BeforeRow:=1```
after the final next in the CopyToNewTable routine, I get an error at:
``` oSourceShape.Table.cell(RowIndex + I - 1, J).Shape.textFrame.textRange.Copy```
which is a couple of lines above. The error is:
```Method 'Copy' of object ' Textrange' failed.```
If I delete it, the add befor, it works fine.
Code follows.
Thanks in advance
Function GetRowOverFlowIndex(oShape As Shape, oPres As Presentation) As Long
Dim Index As Long
Dim sngSldHeight As Single
Dim sngCurrHeight As Single
sngSldHeight = txDrawAreaTop + txDrawAreaHeight ' oPres.PageSetup.SlideHeight
'Get the top position of the shape on the slide
sngCurrHeight = oShape.Top
For Index = 1 To oShape.Table.Rows.Count
'Check if the current height exceeds that of the slide height
If sngCurrHeight + oShape.Table.Rows(Index).Height > sngSldHeight Then
'We have found the row at which the table moves off the slide.
GetRowOverFlowIndex = Index
Exit Function
Else
'Increment the current height
sngCurrHeight = sngCurrHeight + oShape.Table.Rows(Index).Height
End If
Next
End Function
'' Copy that row onwards to a new slide
Sub CopyToNewTable(oSlide As slide, oSourceShape As Shape, RowIndex As Long)
Dim oTableShape As Shape
Dim I As Long
Dim J As Long
Set oTableShape = oSlide.Shapes.AddTable(oSourceShape.Table.Rows.Count - RowIndex + 1, _
oSourceShape.Table.Columns.Count, _
oSourceShape.left, _
oSourceShape.Top, _
oSourceShape.Width)
For I = 1 To oTableShape.Table.Rows.Count
For J = 1 To oTableShape.Table.Columns.Count
'Copy the text from the cell.
oSourceShape.Table.cell(RowIndex + I - 1, J).Shape.textFrame.textRange.Copy
'Paste it into the new location.
oTableShape.Table.cell(I, J).Shape.textFrame.textRange.Paste
Next
oTableShape.Table.Rows(I).Height = oSourceShape.Table.Rows(RowIndex + I - 1).Height
Next
oTableShape.Table.Rows.Add BeforeRow:=1
End Sub
'' Delete the copied rows from the source table from the main routine.
'' Let us bring it altogether into this routine.
Sub SplitTable()
Dim RowIndex As Long
Dim oShp As Shape
Dim oSld As slide
Dim I As Long
Set oShp = ActiveWindow.Selection.ShapeRange(1)
'Check if the selected shape is a table.
If Not oShp.HasTable Then
MsgBox "This is not a table.", vbExclamation
Exit Sub
End If
'Get the row at which table moves off the slide
RowIndex = GetRowOverFlowIndex(oShp, ActivePresentation)
'If no rows are out of slide, just get out otherwise process it
If RowIndex > 0 Then
'Add a new slide for the a new table
Set oSld = ActivePresentation.Slides.Add(oShp.Parent.SlideIndex + 1, oShp.Parent.Layout)
'Now copy the rows to the new table.
Call CopyToNewTable(oSld, oShp, RowIndex)
'Delete the rows from the original table
For I = oShp.Table.Rows.Count To RowIndex Step -1
oShp.Table.Rows(I).Delete
Next
End If
End Sub
I followed #timwilliams advice and re-wrote the routine to duplicate the slide and delete the unnecessary rows on each slide's tables. Thanks Tim for the steerirng!
Related
Is there any way to select the multiples shape from slide with the same shape name.
For e.g., I have 5 shapes with the name "Textbox 60". And I want run a macro which select all the shapes from a slide named "Textbox 60". Have used the below code.
ActiveWindow.View.Slide.Shapes.Range("Textbox 60").Select
Here's one approach:
Sub Tester()
SelectByName ActivePresentation.Slides(1), "Textbox1"
End Sub
Sub SelectByName(sld As Slide, nm As String)
Dim s As Shape, first As Boolean
first = True
For Each s In sld.Shapes
If s.Name = nm Then
s.Select first 'Argument determines whether to add to
first = False ' existing selection, or replace it
End If
Next s
End Sub
You should try following #TinMan's suggestion though - that is the "better" way to go.
Activating and Selecting Objects should be avoided whenever possible. You are better of working with the Shapes using a ShapeRange.
Sub Main()
Dim ShapeRange As ShapeRange
Set ShapeRange = FindShapes(ActiveWindow.View.Slide, "Textbox 60")
If Not ShapeRange Is Nothing Then
End If
End Sub
Function FindShapes(Slide As Slide, Pattern As String) As ShapeRange
Dim Results() As Long
ReDim Results(1 To Slide.Shapes.Count)
Dim n As Long
Dim Index As Long
For Index = 1 To Slide.Shapes.Count
With Slide.Shapes(Index)
.Name = "Textbox 60"
If .Name Like Pattern Then
n = n + 1
Results(n) = Index
End If
End With
Next
If n > 0 Then
ReDim Preserve Results(1 To n)
Set FindShapes = Slide.Shapes.Range(Results)
End If
End Function
Note: I rewrote the code to handle multiple shapes with the same name.
I need to generate a random number between 1 and 30 and display it on every slide. I found the following code online:
Sub UpdateRandomNumber(oSh As Shape)
Dim X As Long
'Make the shape’s text a random number
'X or less
'Change 12 below to any number you’d like:
X = 30
oSh.TextFrame.TextRange.Text = CStr(Random(X))
End Sub
Function Random(High As Long) As Long
'Generates a random number less than or equal to
'the value passed in High
Randomize
Random = Int((High * Rnd) + 1)
End Function
Sub RandomNumber()
End Sub
I need the code to do one thing differently:
The object prompting the action is in the same spot on all slides. When generating and displaying a random number, all slides should be changed accordingly.
When I leave the slide, the previously generated number should be shown instead of the one that was previously generated on this slide.
This creates a random number between 1 and 30. Change the shape name to the actual shape used in your file:
Sub ShapeNumber()
Dim X As Long
Dim ShapeNumber As String
Dim oSlide As Slide
Dim oShape As Shape
X = 30
Randomize
ShapeNumber = Int((X * Rnd) + 1)
For Each oSlide In ActivePresentation.Slides
For Each oShape In oSlide.Shapes
If oShape.Name = "Rectangle 3" Then
oShape.TextFrame.TextRange.Text = ShapeNumber
End If
Next oShape
Next oSlide
End Sub
I have used VBA in the past mostly with excel, but I am not very experienced.
I want to cycle through multiple boxes and make each of them have coincident edges. Like they are sitting on top of each other. I am having trouble identifying the position of the first shape in my selection. I've tried a number of different objects including selection.shaperange.
Dim shp As Visio.Shape
Dim shp1 As Visio.Shape
Dim Pos As Double
Set shp1 = ActiveWindow.Selection.ShapeRange.Item
Pos = shp1.Cells("PinY")
For Each shp In Application.ActiveWindow.Selection
'Change the cell name to the one you want
If shp <> ActiveWindow.Selection.Item(1) Then
Pos = Pos + 6
End If
shp.CellsSRC(visSectionControls, visRowXFormOut, visXFormPinY).FormulaU = Pos & "mm"
Pos = shp.Cells("PinY")
Next shp
End Sub
Can you help me get the position of the first selected item and then I may be able to figure out the rest.
This code will abut the left sides of all but the first-selected shape with the right side of the first-selected shape:
Option Explicit
Public Sub AbutLeftsToPrimaryRight()
Dim sel As Visio.Selection
Set sel = Visio.ActiveWindow.Selection
If (sel.Count < 2) Then
Debug.Print "Select two or more shapes (Use Shift + Click)!"
GoTo Cleanup
End If
Dim shp0 As Visio.Shape
Dim shp As Visio.Shape
'// Get the selection and the primary selected shape,
'// which is item(1). See also: Selection.PrimaryItem
Set shp0 = sel(1)
'// Quick calculate the right side of shp0:
'// PinX - LocPinX + Width.
Dim dRight0 As Double
dRight0 = shp0.CellsU("PinX").ResultIU - shp0.CellsU("LocPinX").ResultIU + shp0.CellsU("Width").ResultIU
'// If shapes are rotated, flipped, or not rectangular,
'// then you'll need to use shp.BoundingBox, which
'// is more complicated
Dim dLeft As Double
Dim dx As Double, px As Double
Dim i As Integer
For i = 2 To sel.Count
'// Get the ith shape:
Set shp = sel(i)
'// Get its Pin:
px = shp.CellsU("PinX").ResultIU
'// Calculate the left side of the shape:
'// PinX - LocPinX:
dLeft = px - shp.CellsU("LocPinX").ResultIU
'// The offset:
dx = dLeft - dRight0
'// Set the new pin:
shp.CellsU("PinX").ResultIUForce = px - dx
Next i
Cleanup:
Set shp0 = Nothing
Set shp = Nothing
Set sel = Nothing
End Sub
Hope this helps!
I'm playing with a progress bar (with basically zero experience with VBA whatsoever). I found the following snippet online:
Sub ProgressBar()
On Error Resume Next
With ActivePresentation
.SectionProperties.SlidesCount(
For N = 2 To .Slides.Count
.Slides(N).Shapes("Progress_Bar").Delete
Set s = .Slides(N).Shapes.AddShape(msoShapeRectangle, 0, .PageSetup.SlideHeight - 10, N * .PageSetup.SlideWidth / .Slides.Count, 10)
Call s.Fill.Solid
s.Fill.ForeColor.RGB = RGB(128, 128, 128)
s.Line.Visible = False
s.Name = "Progress_Bar"
Next N:
End With
End Sub
Note the part with For N = 2 To .Slides.Count. I'd like the progress bar not to reach from the second slide the last one but rather from the second slide to the last slide of the section I called "conclusion". How can I do that?
Thanks!
Edit: My current workaround is a hard coded number of slides that I define as a variable at the beginning of the macro and then use the variable throughout the rest of it.
Here are a couple of bits that should get you started:
LastSlideOf returns the slide index of the last slide in the named section passed to it:
Function LastSlideOf(sSectionName As String) As Long
Dim x As Long
With ActivePresentation.SectionProperties
x = SectionIndexOf(sSectionName)
LastSlideOf = (.FirstSlide(x) + .SlidesCount(x)) - 1
End With
End Function
Function SectionIndexOf(sSectionName As String) As Long
Dim x As Long
With ActivePresentation.SectionProperties
For x = 1 To .Count
If .Name(x) = sSectionName Then
SectionIndexOf = x
End If
Next
End With
End Function
I am attempting to loop the a specific set of frames within each Multipage page in my VBA User_Form. However, it does not seem like I can use a variable object name with each frame control like I can with the pages.
I am getting an error
object doesn't support this property or method
at the following line
For Each cCont in Me.MultiPage1.Pages(PageName).Frames(DataFrame).Controls
My Code
Do While x <= Me.MultiPage1.Pages.Count
PageName = "Page" & CStr(x)
DataFrame = "DataFrame" & CStr(x)
For Each cCont In Me.MultiPage1.Pages(PageName).Frames(DataFrame).Controls
You actually can't iterate the way you would think you could.
First, you need to iterate through all Pages of your MultiPage1.
Second, loop through all Controls inside the current Page , and check if they are of type Frame, if they are you can iterate inside the Frame but the syntax is a little different (see in the code below).
Code
Option Explicit
Private Sub IterateIn_MultiPage()
Dim x As Long, j As Long
Dim cCont As Control
For x = 0 To Me.MultiPage1.Pages.Count - 1 ' <-- loop through all MultiPage Pages
For Each cCont In Me.MultiPage1.Pages(x).Controls ' <-- loop through controls of current page
If TypeOf cCont Is Frame Then ' <-- check if control type is Frame
For j = 0 To cCont.Controls.Count - 1 '<-- loop through all items related to the current Frame collection
MsgBox cCont.Controls(j).Name '<-- display a message box
Next j
End If
Next cCont
Next x
End Sub
Thanks for the help on putting together the code #Shai, for anyone else wondering what the final code looks like here it is. This loops through each frame within each multipage and pastes the caption of checked checkboxes in my desired range.
Option Explicit
Sub IterateIn_MultiPage()
Dim x As Long, j As Long
Dim cCont As Control
Dim counter As Integer
Dim y As Integer
Dim Range As String
y = 1
For x = 0 To ImportData.MultiPage1.Pages.Count - 1
counter = 0
For Each cCont In ImportData.MultiPage1.Pages(x).Controls
Do While counter < 1
If TypeOf cCont Is Frame Then
For j = 0 To cCont.Controls.Count - 1
If cCont.Controls(j).Value = True Then
Range = "E" & y
If counter = 0 Then
Worksheets("Calculations").Range(Range) = cCont.Controls(j).Caption
counter = counter + 1
ElseIf counter = 1 Then
Worksheets("Calculations").Range(Range) = Worksheets("Calculations").Range(Range) & " & " & cCont.Controls(j).Caption
y = y + 1
End If
End If
Next j
End If
Loop
Next cCont
Next x
End Sub