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
Related
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!
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
Hello,
I am trying to set up a form which is a calendar from which the user can select a date (by default the current month appears). The form consists of 42 command buttons (I have left the default name ie. CommandButton1) which I am setting the day number.
At the moment I have a long-winded section of code for each button (I used Excel to generate this rather than type it all out) which locks and hides the button if it is outside of the month in question which looks like this:
NewDate.CommandButton1.Caption = Format(DATlngFirstMonth - DATintDayNumFirst + DATintX, "dd")
If DATintX < DATintDayNumFirst Then
With NewDate.CommandButton1
.Locked = True
.Visible = DATbooShowExtraDays
.ForeColor = RGB(150, 150, 150)
End With
Else
With NewDate.CommandButton1
.Locked = False
.Visible = True
.ForeColor = RGB(0, 0, 0)
End With
End If
I know that I can refer to a command button by:
Dim objCommandButton As Object
Set objCommandButton = NewDate.CommandButton1
..which neatens the code up somewhat. But what I would like to do is refer to the command button as a string so I can loop through all 42, ie.
Dim n as integer
n = 1
Do Until n > 42
Set objCommandButton = NewDate.CommandButton & n
'Some operations
n = n + 1
Loop
Many thanks in advance for assistance.
You can loop through all controls of the form. Try
Sub LoopButtons()
Dim it As Object
For Each it In NewDate.Controls
Debug.Print it.Name
Next it
End Sub
Then you can put conditional expression (if ... then) in place of Debug.Print or whatever. For example
If Instr(it.Name, "CommandButton") Then
'do your code
end if
Here's code which iterates over ActiveX controls on active sheet:
Sub IterateOverActiveXControlsByName()
Dim x As Integer
Dim oleObjs As OLEObjects
Dim ctrl As MSForms.CommandButton
Set oleObjs = ActiveSheet.OLEObjects
For x = 1 To 10
Set ctrl = oleObjs("CommandButton" & x).Object
Next
End Sub
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