如何用VB6实现自动拾取计算CAD图形中线的长度

hlh168

如何用VB6编程实现自动拾取计算CAD图形中线的长度,并将其值返回列表框?

hlh168

望哪位高手能不吝赐教,给编个源码,说明一下

兰州人

你先在VBA中理解清楚

dim ll as acadline

debug.pring ll.length 就是你要的线段长度。

转到VB6.0很简单，关键是你有没有这方面的基础。在这里找一下有实例。

hlh168

VBA中是否要导入vlax.cls类?怎样实施,如果采用VB6又如何实施呢?我是一个新手,劳烦版主能举例讲详细一点好吗?再次谢谢!!!!!!!

hlh168

哪位高手能给个VB6的实例吗,给个有源码实例的链接也行

hlh168

能否将以下的VBA拾取计算CAD线段长度代码,转换成VB6代码?望哪位指点.在此感谢!!!

'Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
Y As Long
End Type

Public Function CreateSelectionSet(Optional ssName As String = "SS3") As AcadSelectionSet
  '返回一个空白选择集
   Dim SS3 As AcadSelectionSet
    On Error Resume Next
    Set SS3 = ThisDrawing.SelectionSets(ssName)
    If Err Then Set SS3 = ThisDrawing.SelectionSets.Add(ssName)
    SS3.Clear
    Set CreateSelectionSet = SS3
End Function

 
Function Long_OverFlow_To_Double(ByVal longVal As Long) As Double
   '将大于2147483647的数值longVal 转换为double类型
    Dim ret_val As Double
    Dim over_long As Double  '2的32次方
    'N(真值)=4294967296#(2的32次方)-[N(真值)]补码
    over_long = 4294967296#
    If longVal < 0 Then
        ret_val = over_long + (longVal)
    End If
Long_OverFlow_To_Double = ret_val
End Function

Public Function Round(ByVal nValue, Optional nPlaces As Integer = 2) As Double
Dim tmp As Integer
nValue = CDbl(nValue)
tmp = Fix(nValue)
nValue = CInt((nValue - tmp) * 10 ^ nPlaces)
Round = tmp + nValue / 10 ^ nPlaces
End Function
Public Function Roundl(ByVal nValue, Optional nPlaces As Integer = 2) As Double
Dim tmp As Long
nValue = CDbl(nValue)
tmp = Fix(nValue)
nValue = CInt((nValue - tmp) * 10 ^ nPlaces)
Roundl = tmp + nValue / 10 ^ nPlaces
End Function
Public Function Roundd(ByVal nValue, Optional nPlaces As Integer = 2) As Double
Dim tmp As Double
nValue = CDbl(nValue)
tmp = Fix(nValue)
nValue = CInt((nValue - tmp) * 10 ^ nPlaces)
Roundd = tmp + nValue / 10 ^ nPlaces
End Function
Function Distance(Point1, Point2) As Double
    Dim dist As Double
    On Error Resume Next
    For i = LBound(Point1) To UBound(Point1)
        dist = dist + ((Point1(i) - Point2(i)) ^ 2)
        If Err Then Exit For
    Next
    Distance = Sqr(dist)
End Function
Function existtext(plineObj As Object) As Boolean
       On Error Resume Next
       Dim textObj As AcadText
      Dim ent As Object
       Dim DataType(0 To 1) As Integer
       Dim Data(0 To 1) As Variant
       Dim ss As AcadSelectionSet
       Dim FilterType(0) As Integer
       Dim FilterData(0) As Variant
       FilterType(0) = 0
       FilterData(0) = "text"
    Dim groupCode As Variant, dataCode As Variant
    groupCode = FilterType
    dataCode = FilterData

      ThisDrawing.SelectionSets("Test").Delete
    Set ss = ThisDrawing.SelectionSets.Add("Test")
   
    Dim InsertionPoint(0 To 2) As Double
   InsertionPoint(0) = plineObj.Coordinate(0)(0): InsertionPoint(1) = plineObj.Coordinate(0)(1): InsertionPoint(2) = 0
     
    Dim corner1(0 To 2) As Double
    Dim corner2(0 To 2) As Double
   
    corner1(0) = plineObj.Coordinate(0)(0) - 20: corner1(1) = plineObj.Coordinate(0)(1) - 20: corner1(2) = 0
    corner2(0) = plineObj.Coordinate(0)(0) + 20: corner2(1) = plineObj.Coordinate(0)(1) + 20: corner2(2) = 0
 
      ss.Select acSelectionSetCrossing, corner1, corner2, groupCode, dataCode
     
        If ss.Count = 0 Then
              DataType(0) = 1001: Data(0) = "MRApplication"
                 DataType(1) = 1000: Data(1) = "qd"
              Set textObj = ThisDrawing.ModelSpace.AddText("起点", InsertionPoint, 500)
              textObj.SetXData DataType, Data
       End If
        
     If ss.Count > 0 Then
     For Each ent In ss
       
               If ent.TextString = "起点" Then
               Else
               DataType(0) = 1001: Data(0) = "MRApplication"
               DataType(1) = 1000: Data(1) = "qd"
               Set textObj = ThisDrawing.ModelSpace.AddText("起点", InsertionPoint, 500)
               textObj.SetXData DataType, Data
               End If
         Next
    End If
ThisDrawing.SelectionSets("Test").Delete
End Function
Function Drawcircle(intpoints As Variant)
      On Error Resume Next
      Dim circleObj As AcadCircle
      Dim DataType(0 To 1) As Integer
       Dim Data(0 To 1) As Variant
       Dim ss As AcadSelectionSet
       Dim FilterType(0) As Integer
       Dim FilterData(0) As Variant
       FilterType(0) = 0
       FilterData(0) = "Circle"
       Dim groupCode As Variant, dataCode As Variant
    groupCode = FilterType
    dataCode = FilterData

      ThisDrawing.SelectionSets("cir").Delete
    Set ss = ThisDrawing.SelectionSets.Add("cir")
         
    Dim corner1(0 To 2) As Double
    Dim corner2(0 To 2) As Double
   
    corner1(0) = intpoints(0) - 6: corner1(1) = intpoints(1) - 6: corner1(2) = 0
    corner2(0) = intpoints(0) + 6: corner2(1) = intpoints(1) + 6: corner2(2) = 0
 
      ss.Select acSelectionSetCrossing, corner1, corner2, groupCode, dataCode
     
        If ss.Count = 0 Then
     Set circleObj = ThisDrawing.ModelSpace.AddCircle(intpoints, 5)
     DataType(0) = 1001: Data(0) = "MRApplication"
     DataType(1) = 1000: Data(1) = "cir"
     circleObj.SetXData DataType, Data  '
    
      End If
ThisDrawing.SelectionSets("cir").Delete
End Function
Function qj(ent As AcadEntity, removeObjects() As AcadEntity, numbera) As Double
  Dim intpoints As Variant
  Dim d1, d2, d3 As Double
  Dim qjx As Double
  qjx = 0
           For m = 0 To numbera
           intpoints = ent.IntersectWith(removeObjects(m), acExtendNone)
           If UBound(intpoints) > -1 Then Exit For
           Next
           
              If UBound(intpoints) > -1 Then
                
                   For jds = (UBound(removeObjects(m).Coordinates) + 1) / 2 - 1 To 1 Step -1
              
                        d3 = Roundd(Distance(removeObjects(m).Coordinate(jds), removeObjects(m).Coordinate(jds - 1)), 2)
                        d2 = Roundd(Distance(removeObjects(m).Coordinate(jds), intpoints), 2)
                        d1 = Roundd(Distance(removeObjects(m).Coordinate(jds - 1), intpoints), 2)
                       
                            If d1 + d2 - 0.03 < d3 And d3 < d1 + d2 + 0.03 Then
                               
                                  If jds > 1 Then
                                   For n = jds - 1 To 1 Step -1
                                  qjx = Distance(removeObjects(m).Coordinate(n), removeObjects(m).Coordinate(n - 1)) + qjx
                                  Next
                                  End If
                               
                                qjx = d1 + qjx
                                Drawcircle intpoints
                                Exit For
                               
                            End If
                  Next
                      
              End If
   qj = qjx
  End Function
Function ybg(sset As AcadSelectionSet) As Boolean
 On Error Resume Next
     Dim ent As AcadEntity
     Dim PStartpoint, PEndpoint As Variant
       For Each ent In sset
       If ent.ObjectName = "AcDbLine" Then
       PStartpoint = ent.StartPoint
       PStartpoint(2) = 0
       ent.StartPoint = PStartpoint
       PEndpoint = ent.EndPoint
       PEndpoint(2) = 0
       ent.EndPoint = PEndpoint
       ent.Update
       End If
    If ent.ObjectName = "AcDbPolyline" Then
       ent.Elevation = 0
        ent.Update
        End If
    Next
End Function

Private Sub CommandButton1_Click()
On Error Resume Next
Dim sset As AcadSelectionSet
Set sset = CreateSelectionSet("SS3")
 Dim xdataOut As Variant
 Dim xtypeOut As Variant

 ListBox1.Clear

              Dim FilterType(0) As Integer
              Dim FilterData(0) As Variant
              FilterType(0) = 0
              FilterData(0) = "LWPolyline"
              sset.SelectOnScreen FilterType, FilterData
            
              Dim ent As Object

              For Each ent In sset
                ent.GetXData "", xtypeOut, xdataOut
                If VarType(xdataOut) = 8204 Then
          
                  If xdataOut(1) = "MR" Then
                  existtext ent
                  ListBox1.AddItem "坐标 X= " & Roundd(ent.Coordinate(0)(0), 0) & " Y= " & Roundd(ent.Coordinate(0)(1), 0)
          
                  End If
                 
                End If
              Next
     ThisDrawing.SelectionSets.Item("SS3").Delete

End Sub

Private Sub CommandButton2_Click()
If Me.CommandButton2.Caption = "设定MR" Then
UserForm1.CommandButton4.Enabled = False
Me.CommandButton2.Caption = "隐藏"
UserForm1.Width = 210
UserForm1.Height = 145
Else
Me.CommandButton2.Caption = "设定MR"
UserForm1.CommandButton4.Enabled = True
UserForm1.Width = 90
UserForm1.Height = 130
End If
End Sub

Private Sub CommandButton3_Click()

On Error Resume Next
 Dim sset As AcadSelectionSet
  ThisDrawing.SelectionSets("SS2").Delete
  Set sset = ThisDrawing.SelectionSets.Add("SS2")
   
    Dim FilterType(0) As Integer
    Dim FilterData(0) As Variant
    FilterType(0) = 0
    FilterData(0) = "LWPolyline,line"
    sset.SelectOnScreen FilterType, FilterData
   
    Dim ent As Object
    For Each ent In sset
      Dim plineObj As AcadLWPolyline
            
      If ent.ObjectName = "AcDbLine" Then
        Dim PStartpoint As Variant
        Dim PEndpoint As Variant
      
        PStartpoint = ent.StartPoint
        PEndpoint = ent.EndPoint

        Dim newVertex(0 To 3) As Double
        newVertex(0) = PStartpoint(0): newVertex(1) = PStartpoint(1)
        newVertex(2) = PEndpoint(0): newVertex(3) = PEndpoint(1)
        Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(newVertex)
      ent.Delete
     
      Else
     
      Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(ent.Coordinates)
     
      ent.Delete
      End If
              
     Dim DataType(0 To 1) As Integer
     Dim Data(0 To 1) As Variant
 
     DataType(0) = 1001: Data(0) = "MRApplication"
     DataType(1) = 1000: Data(1) = "MR"
    
  
     plineObj.SetXData DataType, Data  ' 在直线上附着扩展数据
     Dim color As AcadAcCmColor
    Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
    Call color.SetRGB(254, 0, 0)
    plineObj.TrueColor = color
     
       existtext plineObj
        
         
       Next
ThisDrawing.SelectionSets.Item("SS2").Delete

'retCoord = plineObj.Coordinates
'For Number = LBound(retCoord) To UBound(retCoord)
'a = a & retCoord(Number) & Chr(13)
'Next
End Sub

Private Sub CommandButton4_Click()
Static bRun As Boolean
bRun = Not bRun

If bRun Then
'CommandButton4.Caption = "停止计算"
'UserForm1.CommandButton2.Enabled = False
      'While bRun
           If UserForm1.ComboBox1.ListIndex = 0 Then Call qzx
           'If UserForm1.ComboBox1.ListIndex = 1 Then Call qd
          DoEvents
     ' Wend
 Else
 CommandButton4.Caption = "开始计算"
 UserForm1.CommandButton2.Enabled = True
 Exit Sub
End If

End Sub

Private Sub CommandButton5_Click()
On Error Resume Next
                Dim sset As AcadSelectionSet
                  ThisDrawing.SelectionSets("SS4").Delete
                  Set sset = ThisDrawing.SelectionSets.Add("SS4")
                   
                    Dim FilterType(0) As Integer
                    Dim FilterData(0) As Variant
                    FilterType(0) = 0
                    FilterData(0) = "text"
                    sset.SelectOnScreen FilterType, FilterData
                   Dim xdataOut As Variant
                   Dim xtypeOut As Variant
                   Dim ent As Object
               
                For Each ent In sset
                ent.GetXData "", xtypeOut, xdataOut
                If VarType(xdataOut) = 8204 Then ent.Delete
                Next
                                             
  ThisDrawing.SelectionSets.Item("SS4").Delete
End Sub

Private Sub CommandButton6_Click()

On Error Resume Next
                Dim sset As AcadSelectionSet
                ThisDrawing.SelectionSets("SS111").Delete
                  Set sset = ThisDrawing.SelectionSets.Add("SS111")
                   
                    Dim FilterType(0) As Integer
                    Dim FilterData(0) As Variant
                    FilterType(0) = 0
                    FilterData(0) = "circle"
                    sset.SelectOnScreen FilterType, FilterData
                    sset.Highlight True
                   Dim xdataOut As Variant
                   Dim xtypeOut As Variant
                   Dim ent As Object
               
                For Each ent In sset
                ent.GetXData "", xtypeOut, xdataOut
                If VarType(xdataOut) = 8204 Then ent.Delete
                Next
                                             
  ThisDrawing.SelectionSets.Item("SS111").Delete
End Sub

Private Sub CommandButton7_Click()
Dim a, m, n As Integer
a = 0
Dim temp() As Double
Dim sset As AcadSelectionSet
Set sset = CreateSelectionSet("SS22")
 Dim xdataOut As Variant
 Dim xtypeOut As Variant

              Dim FilterType(0) As Integer
              Dim FilterData(0) As Variant
              FilterType(0) = 0
              FilterData(0) = "LWPolyline"
              sset.SelectOnScreen FilterType, FilterData
            
              Dim ent As Object
            
              For Each ent In sset
                ent.GetXData "", xtypeOut, xdataOut
                If VarType(xdataOut) = 8204 Then
                 If xdataOut(1) = "MR" Then
                  a = 1
                  n = (UBound(ent.Coordinates) + 1) / 2 - 1
                  
               '   Dim tempobj As Variant
              '  Dim objCollection(0 To 0) As Object
               '  Set objCollection(0) = ent
               '   tempobj = ThisDrawing.CopyObjects(objCollection)
                       
                    Dim tempobj As AcadLWPolyline
                     Set tempobj = ent.Copy()
                    For m = 0 To n
                    ent.Coordinate(m) = tempobj.Coordinate(n - m)
                    Next
                   tempobj.Delete
                  existtext ent
                  End If
                 
                End If
              Next
     ThisDrawing.SelectionSets.Item("SS22").Delete
If a = 0 Then MsgBox "找不到桥架"
End Sub

 

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
 
 On Error Resume Next
  
   Dim zcenter(0 To 2) As Double
    Dim magnification As Double
    zcenter(0) = Split(ListBox1.List(ListBox1.ListIndex), " ")(2)
    zcenter(1) = Split(ListBox1.List(ListBox1.ListIndex), " ")(4): zcenter(2) = 0
    magnification = ThisDrawing.GetVariable("VIEWSIZE")
    ZoomCenter zcenter, magnification

       Dim textObj As AcadText
      Dim ent As Object
       Dim DataType(0 To 1) As Integer
       Dim Data(0 To 1) As Variant
       Dim ss As AcadSelectionSet
       Dim FilterType(0) As Integer
       Dim FilterData(0) As Variant
       FilterType(0) = 0
       FilterData(0) = "text"
      
     Dim groupCode As Variant, dataCode As Variant
    groupCode = FilterType
    dataCode = FilterData

      ThisDrawing.SelectionSets("Test").Delete
    Set ss = ThisDrawing.SelectionSets.Add("Test")
   
         
    Dim corner1(0 To 2) As Double
    Dim corner2(0 To 2) As Double
   
    corner1(0) = zcenter(0) - 30: corner1(1) = zcenter(1) - 30: corner1(2) = 0
    corner2(0) = zcenter(0) + 30: corner2(1) = zcenter(1) + 30: corner2(2) = 0
 
      ss.Select acSelectionSetCrossing, corner1, corner2, groupCode, dataCode
     
        If ss.Count = 0 Then
              DataType(0) = 1001: Data(0) = "MRApplication"
                 DataType(1) = 1000: Data(1) = "qd"
              Set textObj = ThisDrawing.ModelSpace.AddText("起点", zcenter, 500)
              textObj.SetXData DataType, Data
       End If
        
     If ss.Count > 0 Then
     For Each ent In ss
       
               If ent.TextString = "起点" Then
               Else
               DataType(0) = 1001: Data(0) = "MRApplication"
               DataType(1) = 1000: Data(1) = "qd"
               Set textObj = ThisDrawing.ModelSpace.AddText("起点", zcenter, 500)
               textObj.SetXData DataType, Data
               End If
         Next
    End If
ThisDrawing.SelectionSets("Test").Delete

End Sub

Private Sub UserForm_Initialize()
ComboBox1.AddItem "取直线"
ComboBox1.AddItem "取点"
ComboBox1.ListIndex = 0
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
ThisDrawing.SelectionSets.Item("SS1").Delete
ThisDrawing.SelectionSets.Item("SS2").Delete
ThisDrawing.SelectionSets.Item("SS3").Delete
ThisDrawing.SendCommand Chr(3) & Chr(3) & Chr(3) & vbCrLf & Chr(3)
End Sub
Sub qzx()
 On Error Resume Next
              
         ThisDrawing.Utility.Prompt (vbCrLf & "取直线计算")
         Dim sset As AcadSelectionSet
         ThisDrawing.SelectionSets("SS1").Delete
         Set sset = ThisDrawing.SelectionSets.Add("SS1")
                   
             Dim FilterType(0) As Integer
             Dim FilterData(0) As Variant
             FilterType(0) = 0
             FilterData(0) = "LWPolyline,line"
     
             sset.SelectOnScreen FilterType, FilterData
             If UserForm1.Visible = False Then Exit Sub
             Call ybg(sset)
              Dim ent As AcadEntity
              Dim removeObjects(0 To 30) As AcadEntity
                   
                    Dim intpoints As Variant
                    Dim numbera, jds, js1, js2 As Integer: Dim qjx, gz, temp As Double
                    numbera = 0: jds = 0
                    gz = 0: qjx = 0: js1 = 0: js2 = 0
                                    
                                    
                   
                    For Each ent In sset
                      ent.GetXData "", xtypeOut, xdataOut
                      If VarType(xdataOut) = 8204 Then
                      Set removeObjects(numbera) = ent
                      numbera = numbera + 1
                      End If
                    Next
                   
              If numbera > 0 Then
              sset.RemoveItems removeObjects
              End If
               
              If numbera = 0 Then
                 For Each ent In sset
                    gz = ent.Length + gz
                    js1 = js1 + 1
                 Next
                End If
               
              If numbera > 0 Then
                  For Each ent In sset
                    qjx = qj(ent, removeObjects, numbera - 1) + qjx
                    If temp <> qjx Then js2 = js2 + 1
                    temp = qjx
                   gz = ent.Length + gz
                  js1 = js1 + 1
                  Next
              End If
                                                
        ThisDrawing.SelectionSets.Item("SS1").Delete
        gz = Round(gz / 1000, 2)
        qjx = Round(qjx / 1000, 2)
        MsgBox js1 & "对象穿管长度:" & gz & "米" & Chr(13) & js2 & "对象穿桥架长:" & qjx & "米"
               
End Sub

Sub qd()
       On Error GoTo Err_Control
                   
       ThisDrawing.Utility.Prompt (vbCrLf & "取点计算")
       Dim lineObj(20) As AcadLine
       Dim strArr(20) As Variant
        Dim p1, p2 As Variant
     Dim m As Double
         Dim k, j As Integer
                   
           k = 1
             strArr(0) = ThisDrawing.Utility.GetPoint(, "获取第" & k & "点")
          ThisDrawing.Utility.Prompt (vbCrLf & "第" & k & "点" & "x=" & strArr(0)(0) & " y=" & strArr(0)(1) & vbCrLf)
          For j = 1 To 20
                k = k + 1
             strArr(j) = ThisDrawing.Utility.GetPoint(strArr(j - 1), "获取第" & k & "点")
              ThisDrawing.Utility.Prompt (vbCrLf & "第" & k & "点" & "x=" & strArr(j)(0) & " y=" & strArr(j)(1) & vbCrLf)
           Set lineObj(j - 1) = ThisDrawing.ModelSpace.AddLine(strArr(j - 1), strArr(j))
          Next
                   
Err_Control:
                    Select Case Err.Number
                         Case -2145320928#
                    
                       ThisDrawing.Utility.Prompt (vbCrLf & "共获取" & k - 1 & "点")
                       ThisDrawing.Utility.Prompt (vbCrLf & "共获取" & k - 1 & "点")
                       ThisDrawing.Utility.Prompt (vbCrLf & "共获取" & k - 1 & "点")
                       ThisDrawing.Utility.Prompt (vbCrLf & "共获取" & k - 1 & "点")
                       ThisDrawing.Utility.Prompt (vbCrLf & "共获取" & k - 1 & "点")
                       ThisDrawing.Utility.Prompt (vbCrLf & "共获取" & k - 1 & "点")
                       ThisDrawing.Utility.Prompt (vbCrLf & "共获取" & k - 1 & "点")
                       
                        For j = 0 To k - 1
                         p1 = strArr(j)
                         p2 = strArr(j + 1)
                         m = m + Distance(p1, p2)
                        Next
                       
                        m = Round(m / 1000, 2)
                     If UserForm1.Visible = False Then GoTo del
                       
                        MsgBox k - 1 & "个点距离之:" & m & "米"
                      
                       
                        For j = 0 To k - 3
                        lineObj(j).Delete
                        Next
                       
                     Case -2147352567#
del:                          For j = 0 To k - 3
                               lineObj(j).Delete
                            Next
                    'ThisDrawing.SendCommand Chr(3) & Chr(3)
                       Case Else
                      '     MsgBox Err.Number & Err.Description
                       End Select

End Sub
望各位高手不吝赐教,谢谢!!!!!