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:
Now that I've found out what went wrong the whole time, I've managed to come up with a solution. This even has the positive side effect, that the whole lens is now a group of standard shapes and can be dealt with accordingly.
Here's the complete code as is (including the user defined functions):
Public Sub lupeNeu() Dim s1 As shape, s2 As shape, s3 As Effect, s4 As ShapeRange, s5 As shape, s6 As ShapeRange Dim l1 As Layer Dim Shift As Long Dim c As New Color Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double c.RGBAssign 255, 255, 255 '***** New Layer If Not LayerExists("Lupen") Then ActivePage.CreateLayer ("Lupen") Set l1 = ActivePage.Layers("Lupen") '***** 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 = l1.CreateEllipse2(x1, y1, calcDist(x1, y1, x2, y2)) Set s3 = s2.CreateLens(cdrLensMagnify, 3) s3.Lens.Freeze '***** Create the workaround ellipse Set s2 = l1.CreateEllipse2(x1, y1, calcDist(x1, y1, x2, y2)) With s2 .Fill.ApplyUniformFill c .OrderToBack End With '***** Define the drag-out location ActiveDocument.GetUserArea x1, y1, x2, y2, Shift, 100, False, cdrCursorSmallcrosshair '***** Take the thing apart and put it together again Set s4 = s3.Lens.Shapes.All Set s6 = s4.CopyToLayer(l1) s3.Lens.Shapes.All.Delete '***** Remove the buggy ellipse s6.DeleteItem 1 '***** Add the replacement s6.Add s2 '***** Move the lens out to the new location s6.Move x2 - xSafe, y2 - ySafe '***** Create a callout-style-line Set s5 = l1.CreateLineSegment(xSafe, ySafe, x2, y2) s5.OrderToBack '***** Rearrange and consolidate s6.Shapes(1).OrderToFront s6.Add s5 s6.Group End Sub Public Function calcDist(x1 As Double, y1 As Double, x2 As Double, y2 As Double) As Double '***** This function calculates the distance between two Document type coordinates Dim returner As Double returner = Math.Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2) calcDist = returner End Function 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