PowerPoint Programming: Indentation with Ruler margin levels not working? - vsto

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

Related

Distortion when ungrouping inserted EMF file into Powerpoint

Background: I am the developer of IguanaTex, a Powerpoint add-in to include LaTeX displays in Powerpoint. IguanaTex can generate vector graphics displays (Powerpoint Shapes, typically Freeforms) by inserting EMF files into a slide, ungrouping them, and doing some clean up (removing extra shapes, further ungrouping, removing lines, ...). These EMF files are typically generated using an external engine (Tex2img) either from LaTeX or from a PDF file that a user wants to convert into an editable shape (not really related to LaTeX, but the whole code base is there to offer that feature, so I put it in).
Issue: I have recently noticed sporadic issues when programmatically ungrouping EMF files, while ungrouping the same file via the GUI does not lead to errors. I have confirmed this occurs on two Windows 10 machines running either Office 2010, Office 2016, or Office 365.
Let's say we insert this EMF file and obtain the following Picture object in Powerpoint:
Inserting the same file using IguanaTex's VBA code leads to the following distorted output, where the "a" and "s" letters are vertically elongated:
The VBA code essentially:
Adds the EMF file as a shape using the Shapes.AddPicture method
Ungroups the shape using the Shape.Ungroup method into a ShapeRange (equivalent to Ungrouping an inserted EMF file in the GUI)
Cleans up by doing one more Ungroup, removing the extra shapes (in our case 1 Autoshape and 1 Rectangle), selecting the group (or Freeform if there is only one) that's at the top, removing the remaining Rectangle, and setting each shape's Outline to be invisible.
Running the code in Debug mode, I could pinpoint the distortion occurring at the first Shape.Ungroup step, which should again in theory be equivalent to doing Shift+Ctrl+G in the GUI (and pressing Yes, as the GUI asks for confirmation when ungrouping EMF files). Note that the distortion still happens when I step over the Ungrouping line.
What is particularly frustrating with this bug, is that if I place in a macro essentially the exact same VBA code that handles Steps 2 and 3 above (everything except inserting the file), then stops the add-in code after the file insertion in Step 1 and run the rest using the macro, that usually doesn't lead to any distortion. I say usually, because this bug is not 100% reproducible: it will sometimes occur, and sometimes it won't. The most reliable way that I found to reproduce it has been to insert the EMF file linked above.
So there doesn't seem to be a particular issue with the code itself, but with the way Powerpoint runs it. Could there be some race condition? Note that I have also noticed that IguanaTex sometimes raises an error in random locations when grouping/ungrouping shapes, and re-running generally solves the issue, which could also point at some race condition. That however seems unlikely here because the distortion issue still occurs when stepping over the code in debug mode.
My questions are thus: does anyone have a clue what is going on, and how can I fix this?
Below is the macro mentioned earlier:
Public Sub Emftoshape()
Dim ConvertLines As Boolean
ConvertLines = False
Dim Sel As Selection
Set Sel = Application.ActiveWindow.Selection
' Get current slide, it will be used to group ranges
Dim sld As Slide
Dim SlideIndex As Long
SlideIndex = ActiveWindow.View.Slide.SlideIndex
Set sld = ActivePresentation.Slides(SlideIndex)
Dim shp As Shape
Set shp = Sel.ShapeRange(1)
' Convert EMF image to object
Dim Shr As ShapeRange
Set Shr = shp.Ungroup
Set Shr = Shr.Ungroup
' Clean up
Shr.Item(1).Delete
Shr.Item(2).Delete
Dim newShape As Shape
If Shr(3).GroupItems.count > 2 Then
Set newShape = Shr(3)
Else ' only a single freeform, so not a group
Set newShape = Shr(3).GroupItems(2)
End If
Shr(3).GroupItems(1).Delete
If newShape.Type = msoGroup Then
Dim arr_group() As Variant
arr_group = GetAllShapesInGroup(newShape)
Call FullyUngroupShape(newShape)
Set newShape = sld.Shapes.Range(arr_group).Group
Dim emf_arr() As Variant ' gather all shapes to be regrouped later on
j_emf = 0
Dim delete_arr() As Variant ' gather all shapes to be deleted later on
j_delete = 0
Dim s As Shape
For Each s In newShape.GroupItems
j_emf = j_emf + 1
ReDim Preserve emf_arr(1 To j_emf)
If s.Type = msoLine Then
If ConvertLines And (s.Height > 0 Or s.Width > 0) Then
emf_arr(j_emf) = LineToFreeform(s).name
j_delete = j_delete + 1
ReDim Preserve delete_arr(1 To j_delete)
delete_arr(j_delete) = s.name
Else
emf_arr(j_emf) = s.name
End If
Else
emf_arr(j_emf) = s.name
If s.Fill.Visible = msoTrue Then
s.Line.Visible = msoFalse
Else
s.Line.Visible = msoTrue
End If
End If
Next
newShape.Ungroup
If j_delete > 0 Then
sld.Shapes.Range(delete_arr).Delete
End If
Set newShape = sld.Shapes.Range(emf_arr).Group
Else
If newShape.Type = msoLine Then
newShapeName = LineToFreeform(newShape).name
newShape.Delete
Set newShape = sld.Shapes(newShapeName)
Else
newShape.Line.Visible = msoFalse
End If
End If
newShape.LockAspectRatio = msoTrue
End Sub
Private Sub FullyUngroupShape(newShape As Shape)
Dim Shr As ShapeRange
Dim s As Shape
If newShape.Type = msoGroup Then
Set Shr = newShape.Ungroup
For i = 1 To Shr.count
Set s = Shr.Item(i)
If s.Type = msoGroup Then
Call FullyUngroupShape(s)
End If
Next
End If
End Sub
Private Function GetAllShapesInGroup(newShape As Shape) As Variant
Dim arr() As Variant
Dim j As Long
Dim s As Shape
For Each s In newShape.GroupItems
j = j + 1
ReDim Preserve arr(1 To j)
arr(j) = s.name
Next
GetAllShapesInGroup = arr
End Function
Private Function LineToFreeform(s As Shape) As Shape
t = s.Line.Weight
Dim ApplyTransform As Boolean
ApplyTransform = True
Dim bHflip As Boolean
Dim bVflip As Boolean
Dim nBegin As Long
Dim nEnd As Long
Dim aC(1 To 4, 1 To 2) As Double
With s
aC(1, 1) = .Left: aC(1, 2) = .Top
aC(2, 1) = .Left + .Width: aC(2, 2) = .Top
aC(3, 1) = .Left: aC(3, 2) = .Top + .Height
aC(4, 1) = .Left + .Width: aC(4, 2) = .Top + .Height
bHflip = .HorizontalFlip
bVflip = .VerticalFlip
End With
If bHflip = bVflip Then
If bVflip = False Then
' down to right -- South-East
nBegin = 1: nEnd = 4
Else
' up to left -- North-West
nBegin = 4: nEnd = 1
End If
ElseIf bHflip = False Then
' up to right -- North-East
nBegin = 3: nEnd = 2
Else
' down to left -- South-West
nBegin = 2: nEnd = 3
End If
xs = aC(nBegin, 1)
ys = aC(nBegin, 2)
xe = aC(nEnd, 1)
ye = aC(nEnd, 2)
' Get unit vector in orthogonal direction
xd = xe - xs
yd = ye - ys
s_length = Sqr(xd * xd + yd * yd)
If s_length > 0 Then
n_x = -yd / s_length
n_y = xd / s_length
Else
n_x = 0
n_y = 0
End If
x1 = xs + n_x * t / 2
y1 = ys + n_y * t / 2
x2 = xe + n_x * t / 2
y2 = ye + n_y * t / 2
x3 = xe - n_x * t / 2
y3 = ye - n_y * t / 2
x4 = xs - n_x * t / 2
y4 = ys - n_y * t / 2
'End If
If ApplyTransform Then
Dim builder As FreeformBuilder
Set builder = ActiveWindow.Selection.SlideRange(1).Shapes.BuildFreeform(msoEditingCorner, x1, y1)
builder.AddNodes msoSegmentLine, msoEditingAuto, x2, y2
builder.AddNodes msoSegmentLine, msoEditingAuto, x3, y3
builder.AddNodes msoSegmentLine, msoEditingAuto, x4, y4
builder.AddNodes msoSegmentLine, msoEditingAuto, x1, y1
Dim oSh As Shape
Set oSh = builder.ConvertToShape
oSh.Fill.ForeColor = s.Line.ForeColor
oSh.Fill.Visible = msoTrue
oSh.Line.Visible = msoFalse
oSh.Rotation = s.Rotation
Set LineToFreeform = oSh
Else
Set LineToFreeform = s
End If
End Function
Edit:
Here is a visual comparison between several ways to insert the EMF file linked above or a modified version of it, where colors are added for illustration:
The EMF file cleaned by John Korchok to remove a clipping mask and a rectangle, and ungrouped with the GUI. Apart from being distorted (the curves are not smooth, and the "a" and "s" are taller than in the original file), the file indeed behaves the same when ungrouping with VBA of with the GUI. That's unfortunately not a viable solution for my problem.
The EMF file ungrouped using VBA (rectangles/autoshapes are normally removed by IguanaTex). "a" and "s" are clearly taller, as can be seen thanks to the horizontal line added as reference.
The EMF file ungrouped with the GUI. This is the desired outcome.
The corresponding PNG file (obtained by converting from PDF using Ghostscript) whose aspect ratio was modified to match the size of the inserted EMF file. Because I trust the PDF/PNG output more, IguanaTex has an option to "vectorize" a PNG display which resizes the ungrouped EMF to match the PNG's size.
When you get variable and unpredictable results, it makes it likely that it's some property of the source file causing the issue. I opened it in both Adobe Illustrator and InkScape. Your sample file has problems:
The text size is really small, about 2.5 points. This means even slight errors will have large visual results.
The top of the k is definitely clipped by the edge of the EMF. I believe the m may be clipped on the left, but the image is so small I can't zoom in enough to see. Since those are the two letters that get resized, that may be a source of the problem.
Your EMF also includes a rectangle that is 3.91" wide and 1.06" tall, enormous by comparison with the tiny text. The upper left corner of this rectangle is at the same position as the rectangle masking the text.
I think it likely that if you test with more real-world files, you'll get better results.

Character Spacing in powerpoint vba

I would like to change the character spacing to the selected text from the paragraph. But my below code change the character spacing for the entire text box. Can anyone help me with this.
For e.g., I just need to increase the character spacing only for the selected text from the entire sentence. Shown in the below picture
ActiveWindow.Selection.ShapeRange.TextFrame2.TextRange.Font.Spacing = 3
Also below code can help me with my purpose. But here the issue is, how can i get the 20 and 45 from the macro.
ActiveWindow.Selection.ShapeRange.TextFrame2.TextRange.Characters(20, 45).Font.Spacing = 3
Your code:
ActiveWindow.Selection.ShapeRange.TextFrame2.TextRange.Font.Spacing = 3
refers to the entire text range of the selected shape. Instead, use:
ActiveWindow.Selection.TextRange2.Font.Spacing = 3
This will act only on the selected text.
You will need to loop over the string and check the character font format for each letter, marking the beginning and end of any bold section of text, then use those positions to apply the spacing:
Dim shp As Shape, i As Long, pStart As Long, n As Long
Set shp = ActivePresentation.Slides(1).Shapes(1)
pStart = 0
With ActiveWindow.Selection.ShapeRange.TextFrame2.TextRange
n = .Characters.Count
For i = 1 To n
If .Characters(i, 1).Font.Bold Then
If pStart = 0 Then
pStart = i
ElseIf pStart > 0 And i = n Then 'ending on bold text
.Characters(pStart, i - pStart).Font.Spacing = 3
End If
Else
If pStart > 0 Then 'transitioning to non-bold
.Characters(pStart, i - pStart).Font.Spacing = 3
pStart = 0
End If
End If
Next i
End With

Why Does It Make A Difference If A Macro is Run When Slide Show Has Started

Apologies if this is a basic question, but I am a newbie at VBA and have spent the past two weeks learning the language. I am trying to make a learning resource using PowerPoint.
I made a good macro which seems to work perfectly when it is run outside the slide show. (I typically just pressed F5 within my VBA Editor to see what the code was doing.) However, when I try running the macro when the slide show is running (using an action button) it does not work as intended. To be more precise it appears to stop running and not show any errors or provide reasons why the macro has stopped.
I tried doing a Google search on this topic, but could not find anything. I would be very grateful if anyone could provide any reasons or suggest any information sources as to why macros work differently when the slide show is running as opposed to not running? Are there any standard practices to ensure that the macros will work when the slide show is run?
Thank you for any comments!
EDIT 02/07/20 - responding to a comment I attach the code below and have explained what I am trying to do in comments below
Sub DataInputMacro()
'This procedure attempts to group (and do a check) of all 20 answer tiles.
Dim oSh As Shape
Dim i As Integer 'This is for the For statement
Dim iix As Integer 'This is to store the x position of the tiles.
Dim iiy As Integer 'This is to store the y position of the tiles.
For i = 1 To 20
If i = 1 Or i = 3 Or i = 5 Or i = 7 Or i = 9 Then
iix = 9
ElseIf i = 2 Or i = 4 Or i = 6 Or i = 8 Or i = 10 Then
iix = 198
ElseIf i = 11 Or i = 13 Or i = 15 Or i = 17 Or i = 19 Then
iix = 587
Else
iix = 774
End If
If i = 1 Or i = 2 Or i = 11 Or i = 12 Then
iiy = 9
ElseIf i = 3 Or i = 4 Or i = 13 Or i = 14 Then
iiy = 113
ElseIf i = 5 Or i = 6 Or i = 15 Or i = 16 Then
iiy = 218
ElseIf i = 7 Or i = 8 Or i = 17 Or i = 18 Then
iiy = 323
Else
iiy = 428
End If
ActiveWindow.Selection.Unselect 'This ensures that nothing has already been selected on the slide (which could then get grouped with the first rectangle!)
For Each oSh In ActivePresentation.Slides("DataInput").Shapes
If IsWithinRange(oSh, iix - 1, iiy - 1, iix + 179, iiy + 97) Then
'MsgBox oSh.Name & " " & oSh.Left
oSh.Select (msoFalse)
End If
Next
If ActiveWindow.Selection.ShapeRange.Count > 1 Then
With ActiveWindow.Selection.ShapeRange.Group
.Name = "GroupAnswer" & i
.Select
End With
ElseIf ActiveWindow.Selection.ShapeRange.Type = msoGroup Then
ActiveWindow.Selection.ShapeRange.Name = "GroupAnswer" & i & "a"
ElseIf ActiveWindow.Selection.ShapeRange.Count = 1 Then
MsgBox "Sorry, but there is a set up issues of your answer boxes. Either (1) one of your answer boxes does not contain a separate textbox or image or (2) there is a missing yellow rectangle! I note for point (1) the text must be placed in a separate text box to the yellow rectangle!"
End
End If
Next i
UpdateTitle 'This is a separate function that updates the title on the front slide.
CheckFor20Groups 'This is a function that checks that there are 20 groups for the rest of the program to use!
End Sub
Shape.Select method does not work in slide view - see remarks here: Shape.Select method (PowerPoint) - so you will have to use another method for working with your shapes - try using a variable to refer to the ShapeRange you are working with rather than ActiveWindow.Selection.ShapeRange - that way you can work with them without needing to select them.

VBA: need to sort shapes

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

OLEObject Height and Width are not consistent

I am currently attaching PDF files and images to my excel sheet as OLE Objects, and trying to control the size of them. (I want the icons to appear along a grid)
The problem is that even though each OLEObject should meet the following specifications, they are sometimes different sizes. Some pdfs have greater lengths, or widths then image files.
How do I make sure they are consistent?
Public Sub OLEObjectNamesReturn()
Dim Count As Integer
Dim Space As Integer
Count = 23
Space = 0
For Each oleObj In ActiveSheet.OLEObjects
Select Case oleObj.Name
Case "CheckBox21"
Case "CheckBox22"
Case "CommandButton21"
Case "CommandButton22"
Case Else
Dim ObjectName As String
ObjectName = oleObj.Name
Set oCell = ActiveSheet.Range("P" & Count)
ActiveSheet.Shapes.Range(Array(ObjectName)).Select
ActiveSheet.Shapes(ObjectName).Height = 30
ActiveSheet.Shapes(ObjectName).Width = 30
ActiveSheet.Shapes(ObjectName).Top = oCell.Top + 7 + Space
ActiveSheet.Shapes(ObjectName).Left = oCell.Left + 7
Count = Count + 1
Space = Space + 15
End Select
Next
End Sub
By default shapes have their aspect ratio (relation W/H) locked ... so in fact both your .Height and .Width settings will change both dimensions (unless they are square from start). If you want perfect squares no matter what is the original W/H ratio of your shapes, unlock the aspect ratio.
Suggestion:
Sub Test()
Dim OleObj As OLEObject
Set OleObj = ActiveSheet.OLEObjects(1) ' embedded PDF A4 ... not icon
OleObj.ShapeRange.LockAspectRatio = msoFalse
OleObj.Height = 30
OleObj.Width = 30
End Sub
Tested wit a PDF originally A4 size ... one doesn't have to like the final look ;-)
If you want to maintain the aspect ratio but still want to fit your OLEObject into a 30x30 grid, you need to apply one single setting to the larger dimension, e.g.
' ....
If OleObj.Width > OleObj.Height Then
OleObj.Width = 30
Else
OleObj.Height = 30
End If
' ....
Then - to horizontally center the object you'd add (30 - OLEObj.Width)/2 to oCell.Left etc etc ...