Hi guys,
I'm kinda stuck on thisone. I've been coding a magnifier glass macro, which works quite okay for the moment. Only thing, I cannot figure out how to do, is to set the background to non-transparent within the lens, that I use for magnification.
Here's the code I've come up with so far:
Public Sub lupeNeu() Dim s1 As shape, s2 As shape, s3 As Effect, s4 As ShapeRange, s5 As shape Dim l1 As Layer Dim Shift As Long Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double '***** New Layer If Not LayerExists("Lupen") Then ActivePage.CreateLayer ("Lupen") Set l1 = ActivePage.Layers("Lupen") '***** no more used 'Set s1 = ActivePage.Layers("Abbildung").FindShape(, cdrBitmapShape) '***** Define glass size and origin ActiveDocument.GetUserArea x1, y1, x2, y2, Shift, 100, False, cdrCursorSmallcrosshair '**** Store the origin xSafe = x1 ySafe = y1 '***** Create magnified lens Set s2 = ActiveLayer.CreateEllipse2(x1, y1, calcDist(x1, y1, x2, y2)) Set s3 = s2.CreateLens(cdrLensMagnify, 3) s3.Lens.Freeze '***** Define the drag-out location ActiveDocument.GetUserArea x1, y1, x2, y2, Shift, 100, False, cdrCursorSmallcrosshair '***** Move the lens out there Set s4 = s3.Lens.Shapes.All s4.Move x2 - xSafe, y2 - ySafe '***** Create a callout-style-line Set s5 = l1.CreateLineSegment(xSafe, ySafe, x2, y2) s5.OrderToBack End Sub
So far, everything I came up with ended in errors. Any help would be appreciated.
EDIT:
Sorry for the inconvenience guys. Here's the missing two custom functions missing:
Public Function LayerExists(ByVal strLayerName As String) As Boolean ' This function will return true if the layer name passed exists Dim objLayer As Layer On Error Resume Next Set objLayer = ActivePage.Layers(strLayerName) LayerExists = Not objLayer Is Nothing End Function Public Function calcDist(x1 As Double, y1 As Double, x2 As Double, y2 As Double) As Double Dim returner As Double returner = Math.Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2) calcDist = returner End Function
Below are the two results I'm getting.
Macro:
Created manually:
When I compare the values in the lens docker on both of them, I cannot see any difference. Both use the "freeze" method.
But somehow the background is opaque when created manually, but it is transparent, when created with the macro.
I've checked the Color and FillColor properties for the EffectLens class, but those are not applicable for the magnifying lens.
Same goes for the additional color parameters in the CreateLens method - except if I missed some obscure settings there, that is.
It might be as easy as the ellipse shape (s2) not having a (uniform color) fill when you create it in the code whereas the manually created ellipse shape uses the default settings for fill and outline (resulting in a white filled shape in your case).
I've also tried this already (sorry for not mentioning), but to no avail.
This code issues the exact same result as the original one:
'***** c is Dimensioned as Color c.RGBAssign 255, 255, 255 '***** Create magnified lens Set s2 = ActiveLayer.CreateEllipse2(x1, y1, calcDist(x1, y1, x2, y2)) s2.Fill.ApplyUniformFill c Set s3 = s2.CreateLens(cdrLensMagnify, 3, c, c, cdrDirectFountainFillBlend) With s3.Lens .Freeze End With
I've run several more tests now and I'm pretty positive on that I'm facing a bug here.
What I've done to verify it:
1. created a style group called "TestStyle", that contains a uniform fill and an outline, transparency set to none.
2. checked if the style will apply properly to shapes created manually.
3. added a line of code, that applies the style to the ellipse created.
4. added a line of code, that takes the ellipse shape from the shape range being created to move the thing and applies the style.
5. checked the result: still transparent, no changes to the outline.
6. checked the properties docker for the resulting lens: the style name is being displayed there for the outline, the transparency and the fill - but the values are NOT the ones of the style.
7. ran a check on the fill color of that ellipse shape: If s4.Shapes(i).Type = cdrEllipseShape Then MsgBox CStr(s4.Shapes(i).Fill.UniformColor.IsWhite) - which returns "True".
8. made a copy of the contained ellipse to the same layer using s4.Shapes(i).CopyToLayer l1
Results of the last step - something that should not even be possible: