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 ...
Related
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.
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
Here's the question I'm having. I need to rotate Word.Shapes in a single Word-Document, but my script will only rotate the first one, and i can't figure out why.
Here's how the Word-Document comes to be (opens a PDF with one Shape per page):
Set wrdDoc = wrdAppMain.Documents.Open(FileName:=sToSaveAs, Visible:=False)
Here's how the loop is designed:
For Each wrdShape In wrdDoc.Shapes
If CheckFormat(wrdShape) = False Then
FitToPage = False
GoTo ExitScript
End If
Next wrdShape
And now the part that's acting up:
Private Function CheckFormat(oShapeToCheck As Word.Shape) As Boolean
On Error GoTo Failed
Dim siAspectRatio As Single
Dim iRotation As Integer
'---- Seitenverhältnis und Rotation berechnen ----
If oShapeToCheck.Height > 0 And oShapeToCheck.Width > 0 Then
siAspectRatio = oShapeToCheck.Height / oShapeToCheck.Width
iRotation = oShapeToCheck.Rotation
Else
ErrorCode = " (PDF)"
GoTo Failed
End If
'---- Kontrolle ob Bild im Querformat vorliegt ----
If siAspectRatio < 1 Then
'---- Kontrolle ob rotiert oder natives Querformat ----
Select Case iRotation
Case 0
oShapeToCheck.IncrementRotation 90
Case 180
oShapeToCheck.IncrementRotation 270
Case 90
oShapeToCheck.IncrementRotation 0
Case 270
oShapeToCheck.IncrementRotation 180
End Select
So and here's where the problem is. Although I the first Word.Shape meeting the criteria will be rotated, any others will not. Additionally if I set the visibility for the Word-Document to TRUE, debug through, and fullscreen the Word-Document before the script performs the rotation, it will rotate any Word.Shape every time.
I tried messing around with .Activate and the like but nothing seems to work. Hope you can help me there!
Thanks!
Markus
So I found a way to make this work. Instead of rotating every Word.Shape individually, I gather them all in a ShapeRange via their Indexes (or whatever the plural is on that one) and rotate them all at once.
Select Case iRotation
Case 0
If bIsDimensioned = False Then
ReDim Preserve RotationArray(0 To 0) As Variant
RotationArray(0) = iShapeIndex
bIsDimensioned = True
Else
ReDim Preserve RotationArray(0 To UBound(RotationArray) + 1) As Variant
RotationArray(UBound(RotationArray)) = iShapeIndex
End If
End Select
And after the ShapeRange is fully populated:
If bIsDimensioned = True Then
Set RotationShapeRange = wrdDoc.Shapes.Range(RotationArray)
RotationShapeRange.IncrementRotation 90
RotationShapeRange.WrapFormat.Type = wdWrapTight
RotationShapeRange.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
RotationShapeRange.RelativeVerticalPosition = wdRelativeVerticalPositionPage
RotationShapeRange.Left = wdShapeCenter
RotationShapeRange.Top = wdShapeCenter
End If
That should be it!
Frustrating, that new code is repasted in broken sections - can't get to work.
I want to Change the captions of several Label boxes. The Labels are sequentially named (DAY1, DAY2, DAY3...DAY14). I need help finding a way to do this;
DAY1.Caption = "1"
without implicitly using the label name...more like:
("DAY" & i).Caption = 1
Where i is an integer. I get a variety of error. My guess is that I don't know the proper object variables or syntax. Any ideas?
I assume your question is in the context of VBA (please edit your question to add the "VBA" tag if so). A nice solution would be to retain a reference to your labels as you create them. You can programmatically create a list of labels like this:
Dim label As Label
Dim dayLabels As New List(Of Label)
For i = 1 To 7
Set label = UserForm.Controls.Add("Forms.Label.1", "Day" & i, True)
dayLabels.Add(label)
With label
.Caption = "Day" & i
.Left = 10
.Width = 50
.Top = 10 * i
End With
Next
Note that you need to show your UserForm as vbModeless to use this code. Also note that the positioning of the labels is accomplished with the .Top and .Left fields; I am using the .Top to value to avoid overlapping of the controls (but you could also use .Left, for example, to distribute them horizontally).
Now that you have all label references stored in the list, you can simply refer to them by index like you were originally trying to do:
dayLabels(3).Text = "The text to appear on Day3 label"
I like where your heads at. I run into two problems. Access VBA registers a compile error for
Dim daylabels As New List(Of Label)
If I remove that line, VBA doesn't recognize any object(s) in line 4;
set label = Userform.Controls.Add("Forms.Label.1, "Day" & I, True
I realize I didn't specify that I was using VBA for Access. I tried playing with the wording. Excel has Userforms but Access treats forms differently...no luck. Here is the full Sub I am using;
Private Sub Command6_Click()
Dim DURATION As Integer
Dim i As Integer
Dim x As Label
DURATION = ((END_DATE.Value) - (START_DATE.Value)) + 1
i = 1
For i = 1 To DURATION
Set x = UserForm.Comtrols.Add("Forms.Label.1", "DAYx" & i, True)
With x
.Caption = "Day" & i
.Left = 10
.Width = 50
.Top = 30 + (10 * i)
End With
Next
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