Distortion when ungrouping inserted EMF file into Powerpoint - vba
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.
Related
How to change Hole Table axis orientation via SolidWorks API?
Is there a way to change orientation (direction) of Hole Table axes with SolidWorks API? I can do it manually by dragging the handles but recorded VBA macro does not contain actual changes. This is what I would like to achieve: Before After I don't have Visual Studio Tools on this PC so I cannot record a C# or VB macro and see if it contains more code. If somebody could check that on their PC I would be grateful.
I have figured it out. This time digging through SolidWorks API Help was useful. By using HoleTable.DatumOrigin.SetAxisPoints() method it is possible to change points that define the Hole Table axes. Important to notice is that SetAxisPoints() changes only the end points of the axis arrows (tips of the arrowheads). Start points get updated automatically. You can get current point values with HoleTable.DatumOrigin.GetAxisPoints2() method. Another thing to notice is that values in the hole table do not get updated automatically. They did update after I manually dragged a an axis point. To get them update by the code set HoleTable.EnableUpdate property to False before and back to True after the call to SetAxisPoints(). Here is the code excerpt that does what I needed: Dim ht As SldWorks.HoleTable Dim htdo As SldWorks.DatumOrigin Dim htdaxpts() As Double Dim htdaxptsnew(0 To 3) As Double Dim ystarty As Double Dim yendx As Double Dim yendy As Double Dim xstartx As Double Dim xendx As Double Dim xendy As Double '... 'here comes code to prepare for Hole Table insertion '... 'insert the Hole Table Set htann = theView.InsertHoleTable2(False, anchorx, anchory, swBOMConfigurationAnchor_BottomLeft, "A", holetemplatepath) If Not htann Is Nothing Then Set ht = htann.HoleTable Set htdo = ht.DatumOrigin 'disable hole table update to get it refresh when done ht.EnableUpdate = False 'get coordinates of the axis arrows (4 pairs of (x,y) doubles: X start(0,1), X end(2,3), Y start(4,5), Y end(6,7)) htdaxpts = htdo.GetAxisPoints2() 'take the values we use xstartx = htdaxpts(0) xendx = htdaxpts(2) xendy = htdaxpts(3) ystarty = htdaxpts(5) yendx = htdaxpts(6) yendy = htdaxpts(7) 'change direction only if Y arrow points up If ystarty < yendy Then yendy = ystarty - (yendy - ystarty) End If 'change direction only if X arrow points left If xstartx > xendx Then xendx = xstartx - (xendx - xstartx) End If 'change position only if X arrow is below Y arrow If xendy < ystarty Then 'we can change end point only so change X end y only xendy = xendy + (ystarty - xendy) * 2 End If 'prepare new axis points (2 pairs of (x,y) doubles: X end(0,1), Y end(2,3)) htdaxptsnew(0) = xendx htdaxptsnew(1) = xendy htdaxptsnew(2) = yendx htdaxptsnew(3) = yendy 'set new axis end points htdo.SetAxisPoints htdaxptsnew 'enable hole table update to refresh the values ht.EnableUpdate = True End If
How do I move around nodes in a shape?
I am trying to create a Sankey-diagram in Excel, and as a start to this, I am trying to create some "entry arrows" for the left part of the diagram, which will look roughly like this: I created it by making a chevron arrow, and dragging the rightmost points of it to line up with the tip of the arrow. Now, to do this for all the arrows I need, I want to do this programmatically, but I can't figure out if there is any way to do much with the nodes (?) of the shape. Trying to record a macro gave me nothing. This is what I have so far, the macro aborts on the Debug.Print line, probably because the node object doesn't have a Left property :P Sub energiInn() Dim r As Range, c As Range Dim lo As ListObject Dim topp As Double, høgde As Double Dim i As Long, farge As Long Dim nd As Object Set lo = Tabell.ListObjects("Energi_inn_elektrolyse") Set r = lo.DataBodyRange topp = 50 With SankeyDiagram.Shapes For i = 1 To r.Rows.Count høgde = Application.WorksheetFunction.Max(10, r.Cells(i, 2) / 50#) With .AddShape(Type:=msoShapeChevron, Left:=50, top:=topp, Width:=200, Height:=høgde) .Name = r.Cells(i, 1) farge = fargekart((i - 1) Mod UBound(fargekart)) .Fill.ForeColor.RGB = RGB(farge Mod 256, (farge \ 256) Mod 256, farge \ 65536) For Each nd In .Nodes Debug.Print nd.Left Next nd End With topp = topp + høgde Next i End With Debug.Print r.Address End Sub Honestly, I am unsure if this can be done at all, but even if it is impossible, it would be nice to get it confirmed :)
What you're looking for is .Nodes.SetPosition. Because it's relative positioning, this can be a challenge. You need to use the objects position elements to make sure the points are moving in relation to the shape. With .AddShape(Type:=msoShapeChevron, Left:=50, Top:=topp, Width:=200, Height:=høgde) .Name = r.Cells(i, 1) .Nodes.SetPosition 2, .Left + .Width, .Top .Nodes.SetPosition 4, .Left + .Width, .Top + .Height First argument is the node index. Next is the x position, which we want all the way to the right of the graphic, so we add the shapes position left to the width of the shape. Last is the y position, first point we want in the topmost corner, so we use the shapes top. Last point, we add the height to the top position to bring to the bottom corner.
I believe it would be more simple drawing this as free form using Shapes.BuildFreeform Method and then converting to shape using FreeformBuilder.ConvertToShape Method. Example: Sub drawEntryArrow() Dim x1 As Single, y1 As Single, w As Single, h As Single Dim oShape As Shape x1 = 10 y1 = 10 w = 200 h = 200 With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, x1, y1) .AddNodes msoSegmentLine, msoEditingAuto, x1 + w, y1 .AddNodes msoSegmentLine, msoEditingAuto, x1 + w, y1 + h .AddNodes msoSegmentLine, msoEditingAuto, x1, y1 + h .AddNodes msoSegmentLine, msoEditingAuto, x1 + w / 2, y1 + h / 2 .AddNodes msoSegmentLine, msoEditingAuto, x1, y1 Set oShape = .ConvertToShape End With End Sub
If you just want to get rid of the point at the right, you can simply delete the node (nodes of a chevron are counted clockwise starting at the top left): .Nodes.Delete 3 To get access to all nodes with the nodes-property of a shape, however, as long as you deal with a standard shape type, you can't access the coordinates. When you use the "edit points", a shape changes its type to msoShapeNotPrimitive - but I couldn't figure out how to do this using VBA. UPDATE Played around a bit (because I'm curious) - just as an example if someone wants to change a shape manually: ' First change Shape Type: ' WILL NOT WORK: sh.AutoShapeType = msoShapeNotPrimitive ' Instead, add a node and remove it immediately. This changes the shape type. .Nodes.Insert c, msoSegmentLine, msoEditingCorner, 100, 100 .Nodes.Delete c + 1 ' Now access the x-coordinate of node 2 and the y-coordinate of node 3 ' (note that we cannot access the coordinates directly) Dim pointsArray() As Single, x As Single, y As Single pointsArray = .Nodes(2).Points x = pointsArray(1, 1) pointsArray = .Nodes(3).Points y = pointsArray(1, 2) ' Now change the x-value of node 3 sh.Nodes.SetPosition 3, x, y
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 ...
calculating the number of rows and colomns in an A4 page when Cell size is X by Y cm
hi all I have been looking all night and can't find anything that will fix my problem I define a cell (A:3) as len=53mm Hgt=33mm and now I want to resize all the cells (from A:3 to ColLast:RowLast ) that fits into a pre defined area ie A4 page where Awidth=210 and Bhight=310 has been specified also why when I print the cell using the following code Sub SetColumnWidthMM(ColNo As Long, mmWidth As Double) ' changes the column width to mmWidth Dim w As Single If ColNo < 1 Or ColNo > 255 Then Exit Sub Application.ScreenUpdating = False w = Application.CentimetersToPoints(mmWidth / 10) While Columns(ColNo + 1).Left - Columns(ColNo).Left - 0.1 > w Columns(ColNo).ColumnWidth = Columns(ColNo).ColumnWidth - 0.1 Wend While Columns(ColNo + 1).Left - Columns(ColNo).Left + 0.1 < w Columns(ColNo).ColumnWidth = Columns(ColNo).ColumnWidth + 0.1 Wend End Sub The printed cell changes size depending on the type of printer I use... ??
Notice that different printers have different margins. So you must expect different layouts for same content in different printers. Always take a look at PageSetup.*Margin. Preferably, do not change your columns width, change page setup scaling. By the way, what are you trying to achieve with your code?
Self explanatory, I hope: With Worksheets("sheetname").PageSetup .PaperSize = xlPaperA4 'Just to ensure we are using A4 FullPageWidth_Points = Application.CentimetersToPoints(21#) AvailablePageWidth_Points = FullPageWidth_Points - .LeftMargin - .RightMargin AvailablePageWidth_Centimeters = AvailablePageWidth_Points / Application.CentimetersToPoints(1#) MaxNumberOfCells = Int(AvailablePageWidth_Points - CellsWidth_Points) End With
PowerPoint Programming: Indentation with Ruler margin levels not working?
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