[编程申请]：问个vba的mirror和选择集的问题（附程序））

Y*Y

我如何在下面的程序中实现我的想法

1。画完一条线或者圆（总之是个对象）将它加入一个选择集中，然后mirror

2。或者画完一条线直接mirror，然后再画线，再镜像

总之就是要将某些线和对象完成镜像

代码在下面
Public acadApp As Object
Public acadDoc As Object
Public MoSpace As Object
'点的数据格式
     
    Type PD
     X As Double
     Y As Double
     Z As Double
    End Type
'画直线函数
    Function DrawLine(SPoint As PD, EPoint As PD) As Object
             Dim LineObj As Object 'Dim LineObj As acadLine
             Dim StartPoint(0 To 2) As Double
             Dim EndPoint(0 To 2) As Double
                 StartPoint(0) = SPoint.X
                 StartPoint(1) = SPoint.Y
                 StartPoint(2) = SPoint.Z
                   EndPoint(0) = EPoint.X
                   EndPoint(1) = EPoint.Y
                   EndPoint(2) = EPoint.Z
             Set LineObj = acadDoc.ModelSpace.AddLine(StartPoint, EndPoint)
                 LineObj.Update
             Set DrawLine = LineObj
    End Function
'画圆函数
    Function DrawCircle(CentPoint As PD, Radius As Double) As Object
             Dim CircleObj As Object 'Dim CircleObj As acadCircle
             Dim CenterPoint(0 To 2) As Double
                 CenterPoint(0) = CentPoint.X
                 CenterPoint(1) = CentPoint.Y
             Set CircleObj = acadDoc.ModelSpace.AddCircle(CenterPoint, Radius)
                 CircleObj.Update
    End Function
'画圆弧函数
   Function DrawArc(CentPoint As PD, Radius As Double, StartAngle, EndAngle) As Object
            Dim ArcObj As Object 'Dim ArcObj As acadArc
            Dim CenterPoint(0 To 2) As Double
            CenterPoint(0) = CentPoint.X
            CenterPoint(1) = CentPoint.Y
            Set ArcObj = acadDoc.ModelSpace.AddArc(CenterPoint, Radius, StartAngle, EndAngle)
            ArcObj.Update
            Set DrawArc = ArcObj
    End Function
'创建图层函数
   Function AddLayer(LayerName As String, ltName As String, LayerColor As Long) As Object
            'LayerName--层名  ltName--线型名,为ACAD.lin中的标准线型
            'LayerColor--层颜色  值1--255
            '功能：在当前编辑的图形文件中按指定线型和颜色建立图层并设为当前层
    Dim newObj As Object
        Set newObj = acadDoc.Layers.Add(LayerName)
        newObj.Color = LayerColor 'acRed
        newObj.Linetype = ltName
        Set acadDoc.ActiveLayer = newObj
        Set AddLayer = newObj
   End Function
'将某一层设为当前层函数
   Function SetLayer(Name As String) As Object
             On Error Resume Next
             Dim LayerObj As Object
             Set LayerObj = acadDoc.Layers(LName)
             Set acadDoc.ActiveLayer = LayerObj
   End Function

'读取表中字段函数
Function GetValues(byval iID as integer) as double
   adodc1.recordsource="select UnitPrice from Products where ProductID = " & iID
   adodc1.refresh
   if adodc1.recordset.recordcount>0 then
      if isnull(adodc1.recordset.fields("UnitPrice").value)=false then
         GetValues=adodc1.recordset.fields("UnitPrice").value
      else
         GetValues=0
      end if
   end if
end function
'''====================================
Private Sub DrawAllMap_Click()
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
   Err.Clear
   Set acadApp = CreateObject("AutoCAD.Application")
   If Err Then
      MsgBox Err.Description
      Exit Sub
   End If
End If
'MsgBox "现在运行"+acadApp.Name+"版本号"+acadApp.Version
acadApp.Visible = True
acadApp.Left = 0
acadApp.Top = 0
acadApp.Width = 1000
acadApp.Height = 700
'Dim acadDoc AS acadDocument
Set acadDoc = acadApp.activeDocument '设定当前文档为活动文档

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''以上为启动AuotCAD绘图软件
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const Pi = 3.1415926

   
'定义X,X1,..X8,定义Y,Y1,...Y9,定义R1,...R2,定义a1,a2,...,a4
Dim X  As Double
Dim X1 As Double
Dim X2 As Double
Dim X3 As Double
Dim X4 As Double
Dim X5 As Double
Dim X6 As Double
Dim X7 As Double
Dim X8 As Double
Dim M As Double

'以上为定义X轴方向几何尺寸

Dim Y  As Double
Dim Y1 As Double
Dim Y2 As Double
Dim Y3 As Double
Dim Y4 As Double
Dim Y5 As Double
Dim Y6 As Double
Dim Y7 As Double
Dim Y8 As Double
Dim Y9 As Double
'以上为定义Y轴方向几何尺寸

Dim R1 As Double
Dim R2 As Double
'以上为定义半径尺寸

Dim a1 As Double
Dim a2 As Double
Dim a3 As Double
Dim a4 As Double

X = Val(TxtX(0).Text)
X1 = Val(TxtX(1).Text)
X2 = Val(TxtX(2).Text)
X3 = Val(TxtX(3).Text)
X4 = Val(TxtX(4).Text)
X5 = Val(TxtX(5).Text)
X6 = Val(TxtX(6).Text)
X7 = Val(TxtX(7).Text)
X8 = Val(TxtX(8).Text)
M = Val(TxtX(9).Text)

Y = Val(TxtY(0).Text)
Y1 = Val(TxtY(1).Text)
Y2 = Val(TxtY(2).Text)
Y3 = Val(TxtY(3).Text)
Y4 = Val(TxtY(4).Text)
Y5 = Val(TxtY(5).Text)
Y6 = Val(TxtY(6).Text)
Y7 = Val(TxtY(7).Text)
Y8 = Val(TxtY(8).Text)
Y9 = Val(TxtY(9).Text)

R1 = Val(TxtX(10).Text)
R2 = Val(TxtX(11).Text)

a1 = Val(Txt(12).Text)
a2 = Val(Txt(13).Text)
a3 = Val(Txt(14).Text)
a4 = Val(Txt(14).Text)

'''''''''''''''''''''''
'几何参数尺寸定义完毕
'''''''''''''''''''''''

Dim IP1 As PD '定义俯视图的绘图基点(InsertPoint=IP
Dim IP2 As PD '定义主视图的绘图基点
    IP1.X = X
    IP1.Y = Y
    IP2.X = X
    IP2.Y = Y + Y1 / 2 + Y2 + Y3 + 30
'IP1,IP2为俯视图和主视图的绘图基点



Dim P1 As PD
Dim P2 As PD
    P1.X = IP1.X - X1 / 2
    P1.Y = IP1.Y + Y1 / 2
    P2.X = IP1.X + X1 / 2
    P2.Y = IP1.Y + Y1 / 2
Dim P3 As PD
Dim P4 As PD
    P3.X = IP1.X - X1 / 2
    P3.Y = IP1.Y + Y1 / 2 + Y2
    P4.X = IP1.X + X1 / 2
    P4.Y = IP1.Y + Y1 / 2 + Y2
Dim P5 As PD
Dim P6 As PD
    P5.X = IP1.X - X2 / 2
    P5.Y = IP1.Y + Y1 / 2 + Y2
    P6.X = IP1.X + X2 / 2
    P6.Y = P5.Y
Dim P7 As PD
Dim P8 As PD
    P7.X = P5.X
    P7.Y = P5.Y + Y3
    P8.X = P6.X
    P8.Y = P7.Y

'以下画直线12，34，13，24，78，57，68
DrawLine P1, P2'如何画完这条线后我想做该条线关于某个对称轴的mirror该如何做，我自己写的mirror成功不了
DrawLine P3, P4
DrawLine P1, P3
DrawLine P2, P4
DrawLine P7, P8
DrawLine P5, P7
DrawLine P6, P8
'以下太多故略
'......
End sub

efan2000

在VBA中，Mirror仅对实体有效，不能用于选择集，但可以通过枚举选择集中的每个实体，分别进行镜像操作。Mirror的用法：
RetVal = object.Mirror(Point1, Point2)
Object        实体对象
Point1        Variant 型(Double型的三维点数组)
Point2        Variant 型(Double型的三维点数组)
RetVal        镱像后的实体

Y*Y

我是在vb中用的，斑竹大人能不能写个例子（就我上面的代码）

可不可以不用 RetVal,每根线都用retval太多了；能不能这么写
DrawLine P3, P4 .Mirror Point1,Point2
或者
dim ABC as object
ABC=DrawLine P3, P4.Miirro(Point1,Point2)
ABC=DrawLine P7, P8.Mirror(Point1,Point2)

efan2000

不用这么麻烦，看这个，Function DrawLine(SPoint As PD, EPoint As PD) As Object，你不是创建了一个画直线的函数，函数的返回值就是一个直线对象，那么就可以直接对它进行Mirror操作。像这样：DrawLine(P3, P4).Mirror Point1,Point2，如果要返回对象的话，就这样：Set ABC=DrawLine(P3, P4).Miirror(Point1,Point2)。