I have 3 text boxes that are created on a slide via vba. this means that they will all start with the name "TextBox" but the numbers behind the name will be different every time. these are the only text boxes on the slide
I want to use vba to group all text boxes together.
no need to change anything, just group them so they move as a group if needed.
I figured it out
I knew I was only going to have 3 text boxes at a time so this worked. basically since the text boxes could end in any number, I renamed them to box1, box2, box3. and then grouped the box shapes
Dim SLD As Slide
Dim D As Long
Dim T As Integer
Set SLD = ActivePresentation.Slides(9)
T = 1
For D = SLD.Shapes.Count To 1 Step -1
If SLD.Shapes(D).Type = msoTextBox Then
SLD.Shapes(D).Name = "Box" & T
T = T + 1
End If
Next
SLD.Shapes.Range(Array("Box1", "Box2", "Box3")).Group
Related
I have a problem with deleting tables from all slides in a presentation.
At first the program is counting how much shapes are on the slide.
If the shape is a table delete it.
An error appears. 5 shapes are counted at the beginning. Later only 3 left because 2 tables were got deleted. I dont understand why. n_shapes is counting the shapes before the loop but I think Powerpoint is changing it dynamic.
Anyone an idea how to fix it?
Sub tab_del()
Dim n_shapes As Integer
Dim shape_count As Integer
Dim n_slides As Integer
Dim slide_count As Integer: slide_count = ActivePresentation.Slides.Count
For n_slides = 1 To ActivePresentation.Slides.Count
With ActivePresentation.Slides(n_slides).Shapes
n_shapes = .Count
For shape_count = 1 To n_shapes
If .Item(shape_count).Type = msoTable Then .Item(shape_count).Delete
Next shape_count
End With
Next n_slides
End Sub
Recently, in an interview I encountered a question in VBA. The question is:
Write a program to sort the shapes in a worksheet, like for example : I have various shapes like circle, triangle, rectangle, pentagon... This needs to be sorted and placed one below the other.
I tried with Shapes object and msoshapeRectangle method. But it didnt work.
Could you please tell me is this possible to be done?
Thanks
It was an interesting challenge, so I did it. Might as well post the result (commented for clarity):
Sub tgr()
'There are 184 total AutoShapeTypes
'See here for full list
'https://msdn.microsoft.com/VBA/Office-Shared-VBA/articles/msoautoshapetype-enumeration-office
Dim aShapeTypes(1 To 184) As String
Dim ws As Worksheet
Dim Shp As Shape
Dim i As Long, j As Long
Dim vShpName As Variant
Dim dLeftAlign As Double
Dim dTopAlign As Double
Dim dVerticalInterval As Double
Dim dHorizontalInterval As Double
Dim dPadding As Double
Set ws = ActiveWorkbook.ActiveSheet
'Sort order will be by the AutoShapeType numerical ID
'Using this, shapes will be sorted in this order (incomplete list for brevity):
' Rectangle, Parallelogram, Trapezoid, Diamond, Rounded rectangle, Octagon, Isosceles triangle, Right triangle, Oval, Hexagon
'Note that you can use a Select Case to order shapes to a more customized list
'I use this method to put the -2 (indicates a combination of the other states) at the bottom of the sort order
For Each Shp In ws.Shapes
Select Case Shp.AutoShapeType
Case -2: aShapeTypes(UBound(aShapeTypes)) = aShapeTypes(UBound(aShapeTypes)) & "||" & Shp.Name
Case Else: aShapeTypes(Shp.AutoShapeType) = aShapeTypes(Shp.AutoShapeType) & "||" & Shp.Name
End Select
Next Shp
'Now that all shapes have been collected and put into their sort order, perform the actual sort operation
'Adjust the alignment and vertical veriables as desired
'The Padding variable is so that the shapes don't start at the very edge of the sheet (can bet set to 0 if that's fine)
'I have it currently set to sort the shapes vertically, but they can be sorted horizontally by uncommenting those lines and commenting out the vertical sort lines
dPadding = 10
dLeftAlign = 5
dTopAlign = 5
dVerticalInterval = 40
dHorizontalInterval = 40
j = 0
For i = LBound(aShapeTypes) To UBound(aShapeTypes)
If Len(aShapeTypes(i)) > 0 Then
For Each vShpName In Split(Mid(aShapeTypes(i), 3), "||")
With ws.Shapes(vShpName)
'Vertical Sort
.Left = dLeftAlign
.Top = j * dVerticalInterval + dPadding
'Horizont Sort
'.Top = dTopAlign
'.Left = j * dHorizontalInterval + dPadding
End With
j = j + 1
Next vShpName
End If
Next i
End Sub
Hello everyone I have two listboxes. The first listbox contains all the items to choose from. After selecting an item, a user clicks on an 'ADD' command button to copy that value onto the range of the second listbox. I believe most of you have seen similar add/remove listboxes.
Both listboxes were created by inserting controls and they are populated by an input range of items on a hidden worksheet.
Here is my problem: adding names is works fine, however the 'remove' procedure I created seems to take a long time to complete since the list of items can be more than 200 items.
I use the following code to match a selected listbox value with the input range value and then it clears the contents of the cell in the input range:
Sub remove()
Dim r As Long
Dim al As ListBox
Dim d As Range
Dim dd As Range
Dim allpick As Worksheet
Set al = Worksheets("LISTBOX").ListBoxes("listselected")
Set allpick = Worksheets("columns")
Set dd = allpick.Range("selectedNAMES")
With al
For r = 1 To .ListCount
If .selected(r) Then
For Each d In dd
If d.Value = .List(r) Then
d.ClearContents
End If
Next d
End If
Next r
End With
End Sub
Is there an alternative code or structure I could use so that it doesn't take so long to complete?
I used the find function stated by commenters and wrote the code below. It is much faster and is exactly what I wanted. However, I didn't know what to put after "IF CELL IS NOTHING THEN" so i just used calculate. Any suggestions?
Dim r As Long
Dim al As ListBox
Dim strNAME As String
Dim names As Worksheet
Set names = Worksheets("names")
Set al = Worksheets("HOME").ListBoxes("selectednames")
With al
For r = 1 To .ListCount
If .Selected(r) Then
strNAME = .List(r)
Set cell = names.Range("currentnames").Find(What:=strNAME)
If cell Is Nothing Then
Calculate
Else: cell.ClearContents
End If
End If
Next r
End With
I'm building a questionnaire within excel, and have been asked to include a "You are on sheet X out of Y" type indicator on each page.
The number of visible sheets varies depending on answer to some of the early quesitons (irrelevant question sets are hidden, etc.), as such both the numerator and denominator in that statement are variables.
I've got a label (Label1) on each page which I can write the caption of, I've managed to count the total number of visible sheets and tie the caption writing to the sheet activation event:
Private Sub Worksheet_Activate()
If Range("AZ1").Value = "1" Then
Dim v
For Each s In ActiveWorkbook.Sheets
If s.Visible Then v = v + 1
Next s
ActiveSheet.Label1.Caption = "Currently viewing page X of " & v & vbCrLf
End If
End Sub
This correctly writes a denominator into each label on each sheet.
In order to find the numerator though, I need to be able to find the number of unhidden sheets to the left of the active sheet.
Does anyone know how I might do this using VBA?
The Worksheet.Index-Property helps you out here:
Dim n As Long
Dim i As Long
n = 0
For i = 1 To ActiveSheet.Index
If ThisWorkbook.Worksheets(i).Visible Then
n = n + 1
End If
Next
Debug.Print n
Recently we upgraded one our PowerPoint addin to support 2007 and 2010. most of the items we were able to port without problem. one problem we have is that indentations doesn't work when create tables or shapes using the addin.
for eg: same table gets dropped with proper indentation in 2003 but same thing doesn't get indentation when added to using 2007.
below is the code snippet that allows indenting:
With PropertyValues.ObjShape.Table.Cell(row, col).Shape.TextFrame.Ruler
For rulerCount = 0 To 5
.Levels(rulerCount).FirstMargin = rulerFirstMargin(rulerCount) '.LeftMargin = rulerLeftMargin
.Levels(rulerCount).LeftMargin = rulerLeftMargin(rulerCount) 'Left indent marker
Next rulerCount
End With
any idea why this is not working ?
I read the following thread too but didn't help much http://answers.microsoft.com/en-us/office/forum/office_2007-customize/why-shapetextframerulerlevelsi-cant-set-the-bullet/9eac3e46-b13b-433e-b588-216ead1d9c1a?tab=AllReplies#tabs
Updated Code:
PropertyValues.ObjShape.Table.Cell(row, col).Shape.TextFrame.TextRange.Text = "N/A"
With PropertyValues.ObjShape.Table.Cell(row, col).Shape.TextFrame
'Dim rulerCount As Short
For rulerCount = 1 To 5
.Ruler.Levels(rulerCount).FirstMargin = 10 * rulerCount 'rulerFirstMargin(rulerCount) '.LeftMargin = rulerLeftMargin
.Ruler.Levels(rulerCount).LeftMargin = 20 * rulerCount 'rulerLeftMargin(rulerCount) 'Left indent marker
Next rulerCount
End With
PropertyValues.ObjShape.Table.Cell(row, col).Shape.TextFrame.TextRange.Text = text
FWIW, in 2007 and up, you can now have up to 9 ruler levels instead of 5 as in earler versions. But your code should work as is. Here's a simplified version that does work on an arbitrary cell (2,2) of a table:
Dim oSh As Shape
Dim x As Long
Set oSh = ActiveWindow.Selection.ShapeRange(1)
With oSh.Table.Cell(2, 2).Shape.TextFrame
For x = 1 To 9
.Ruler.Levels(x).LeftMargin = x * 10
.Ruler.Levels(x).FirstMargin = x * 20
Next
End With
The other thing you might be running into is that you can apply certain types of formatting (including ruler settings) all you like; if there's no text at the level you're applying it to, PPT won't bark. It'll ignore you. Your settings will have no effect. Sometimes you need to check for text, supply some if there's none there (something highly improbable in the real world) then delete all instances of your improbable text afterwards.
Ugly. Yes.
Here we add text and set indent levels before trying to FORMAT each indent level:
Sub test()
Dim oSh As Shape
Set oSh = ActiveWindow.Selection.ShapeRange(1)
Dim RulerCount As Long
Dim sTemp As String
sTemp = "##$%" ' dummy text
With oSh.Table.Cell(2, 3).Shape.TextFrame
For RulerCount = 1 To 5
.TextRange.Paragraphs(RulerCount).Text = sTemp & vbCrLf
.TextRange.Paragraphs(RulerCount).IndentLevel = RulerCount
Next
For RulerCount = 1 To 5
.Ruler.Levels(RulerCount).FirstMargin = 10 * RulerCount 'rulerFirstMargin(rulerCount) '.LeftMargin = rulerLeftMargin
.Ruler.Levels(RulerCount).LeftMargin = 20 * RulerCount 'rulerLeftMargin(rulerCount) 'Left indent marker
Next RulerCount
End With
End Sub