TheSwamp
Code Red => VB(A) => Topic started by: havano on May 20, 2006, 08:20:02 AM
-
I have created some geometry in a drawing. Mainly polylines, linear dimensions and texts.
Now I wish to be able to mirror all geometry on a specific layer around a vertical axis (without keeping the original).
I know I could use sendcommands, but I rather wouldn't. Any suggestions? The more simple the better!
-
havano, you can use 3dmirror,which doesn't use an axis but a plane.
Here is something that flips things. Adjust it to your needs, download the selectionset function if you dont have one.
Sub Flip()
Dim ss As AcadSelectionSet
Dim Ent As AcadEntity
Dim P1, P2, P3
P1 = ThisDrawing.GetVariable("ucsorg")
P2 = ThisDrawing.GetVariable("ucsxdir")
P3 = ThisDrawing.GetVariable("ucsydir")
Set ss = sset(8, "Specificlayer")
For Each Ent In ss
Ent.Mirror3D P1, P2, P3
Ent.Delete
Next
End Sub
-
This could work for you:
'limited the flipping to drawingspace and also flips entity's on layer with the name as a part of the layer name
Sub MirrorByLayer()
Dim FlipLinePoint1 As Variant
Dim FlipLinePoint2 As Variant
Dim LayerName As String
Dim Layer As AcadLayer
Dim Layers As AcadLayers
Dim LayerArr() As AcadLayer
Dim LayerCounter As Long
Dim AcEnt As AcadEntity
FlipLinePoint1 = ThisDrawing.Utility.GetPoint(, "Enter the first point of the mirrorline: ")
FlipLinePoint2 = ThisDrawing.Utility.GetPoint(FlipLinePoint1, "Enter the second point of the mirrorline: ")
Do While (LayerName = "")
LayerName = ThisDrawing.Utility.GetString(True, "Enter a (Partial) LayerName or to flip (000) exits this macro: ")
If LayerName = "000" Then Exit Sub
'Finding all legitemate layers
For Each Layer In ThisDrawing.Layers
If InStr(1, Layer.Name, LayerName, vbTextCompare) Then
ReDim Preserve LayerArr(LayerCounter)
LayerCounter = LayerCounter + 1
Set LayerArr(LayerCounter - 1) = Layer
End If
Next
'continue loop if no layer was found
If UBound(LayerArr) = 0 Then LayerName = ""
Loop
'find entity's on these layers.
For Each AcEnt In ThisDrawing.ModelSpace
For LayerCounter = 0 To UBound(LayerArr)
'Mirror the bugger
If AcEnt.Layer = LayerArr(LayerCounter).Name Then
AcEnt.Mirror FlipLinePoint1, FlipLinePoint2
AcEnt.Delete
Exit For
End If
Next
Next
End Sub
-
Thanks sofar. With your help I wrote this code. But there's something wrong and I can't find out what...
Public Sub HorizontalFlip()
'Corrected after Bryco's hint about variable declaration syntax (ver. below).
'Now it works!
Dim Thingy As AcadEntity
Dim LayerName As String
Dim MostLeftX as Double, MostRightX As Double 'thanks Bryco!
Dim BBoxMin, BBoxMax 'variants, will later be specified by GetBoundingBox
Dim FlippointA(0 To 2) as Double, FlippointB(0 To 2) As Double 'thanks Bryco!
MostLeftX = 2147483647: MostRightX = -2147483647
LayerName = "0" 'can be any valid layername
For Each Thingy In ThisDrawing.ModelSpace
If Thingy.Layer = LayerName Then
Thingy.GetBoundingBox BBoxMin, BBoxMax
If BBoxMin(0) < MostLeftX Then MostLeftX = BBoxMin(0)
If BBoxMax(0) > MostRightX Then MostRightX = BBoxMax(0)
End If
Next
'I now have MostLeftX and MostRightX for all geometry on layer.
'next, I define the mirror line, halfway between MostLeftX and MostRightX
FlippointA(0) = (MostLeftX + MostRightX) / 2: FlippointB(0) = FlippointA(0)
FlippointA(1) = 0: FlippointB(1) = 1
FlippointA(2) = 0: FlippointB(2) = 0 'endpoints of the vertical mirror line
'finally, I want to horizontally flip all entities on the layer
For Each Thingy In ThisDrawing.ModelSpace
If Thingy.Layer = LayerName Then
Thingy.Mirror FlippointA, FlippointB 'thanks Dnereb!
Thingy.Delete
End If
Next
End Sub
What am I overlooking?
-
Dim FlippointA(0 To 2), FlippointB(0 To 2) As Double
only one of them is a double
-
Thank you so much Bryco!
I immediately reviewed my current project and discovered similar faulty variable declarations. Apparently I got away with them sofar.
-
Thanks, and thank you Berend. The selectionset is not really the way to go.
-
No Thx,
It was just a simplified part of something I had laying around with an simple userinterface added.
Have fun to Y'all.