|
|
发表于 2008-7-3 01:17:00
|
显示全部楼层
能否将以下的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
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 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
望各位高手不吝赐教,谢谢!!!!! |
|
置顶卡
