练手示例：给每个直线顶点加序号
本帖最后由 作者 于 2008-6-26 12:52:22 编辑这是一个练手的小示例。有兴趣的各位大侠可以引伸到零件标注号等小程序，还有其它的什么要求，大家都提出来，玩玩.
Function CreatSelectionSet(InputEntityObjectName As Variant, Pt1 As Variant, Pt2 As Variant) As AcadSelectionSet
On Error Resume Next
Dim SSet As AcadSelectionSet
If Not IsNull(ThisDrawing.SelectionSets.Item("SelectEntity")) Then
Set CreatSelectionSet = ThisDrawing.SelectionSets.Item("SelectEntity")
CreatSelectionSet.Delete
End If
Set CreatSelectionSet = ThisDrawing.SelectionSets.Add("SelectEntity")
'Pt1 = ThisDrawing.Utility.GetPoint(, "Input First Point")
'Pt2 = ThisDrawing.Utility.GetPoint(Pt1, "Input First Point")
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
'ReDim dataValue(UBound(InputEntityObjectName)) As Variant
gpCode(0) = 0
For ii = 0 To UBound(InputEntityObjectName)
dataValue(ii) = InputEntityObjectName(ii)
Next ii
CreatSelectionSet.Select acSelectionSetWindow, Pt1, Pt2, gpCode, dataValue
End Function
Sub ReadTable()
Dim Pt1(0 To 2) As Double, Pt2(0 To 2) As Double
Dim SSet As AcadSelectionSet
Dim InputEntityObjectName As Variant
Pt1(0) = 2850: Pt1(1) = 2660: Pt1(2) = 0
Pt2(0) = -10: Pt2(1) = -10: Pt2(2) = 0
InputEntityObjectName = Array("Line", "Text", "Dimension")
Set SSet = CreatSelectionSet(InputEntityObjectName, Pt1, Pt2)
Debug.Print SSet.Count
Dim Ent As AcadEntity, DrawingText As AcadText
Dim DrawingLine As AcadLine, DrawingCircle As AcadCircle
ii = 1
Dim alignmentPoint(0 To 2) As Double
alignmentPoint(0) = 5: alignmentPoint(1) = 3: alignmentPoint(2) = 0
For Each DrawingLine In SSet
With ThisDrawing.ModelSpace
Set DrawingCircle = .AddCircle(DrawingLine.EndPoint, 35)
Set DrawingText = .AddText(ii, alignmentPoint, 30)
With DrawingText
'.HorizontalAlignment = acHorizontalAlignmentFit
.Alignment = acAlignmentMiddleCenter
.TextAlignmentPoint = DrawingLine.EndPoint
End With
End With
ii = ii + 1
Next
End Sub
方法1Sub ll()
Dim LineData As AcadLine, ArcData As AcadArc
Dim DrawingText As AcadText, DrawingCircle As AcadCircle
Close #1
Open "D:\ls.txt" For Output As #1
Write #1, "m1", "m2", "m3", "m4", "m5", "m6", "m7", "m8", "m9", "m10", "m11", "m12"
Dim Ent As AcadEntity
ii = 1
For Each Ent In ThisDrawing.ModelSpace
m1 = Ent.ObjectName
m2 = Ent.ObjectID
Select Case Ent.ObjectName
Case "AcDbLine"
Set LineData = Ent
With LineData
Set DrawingCircle = ThisDrawing.ModelSpace.AddCircle(.StartPoint, 35)
Set DrawingText = ThisDrawing.ModelSpace.AddText(ii, .EndPoint, 30)
With DrawingText
.Alignment = acAlignmentMiddleCenter
.TextAlignmentPoint = LineData.StartPoint
ii = ii + 1
End With
m3 = Round(.StartPoint(0), 5)
m4 = Round(.StartPoint(1), 5)
m5 = Round(.StartPoint(2), 5)
m6 = Round(.EndPoint(0), 5)
m7 = Round(.EndPoint(1), 5)
m8 = Round(.EndPoint(2), 5)
End With
End Select
Write #1, m1, m2, m3, m4, m6, m7, m8
Next Ent
Close #1
End Sub
取每个端点的坐标,并输出!<img alt="" src="http://www.mjtd.com/bbs/Skins/default/topicface/face5.gif"/> 以下程序将点送到Excel
Sub ll()
ThisDrawing.ActiveTextStyle.fontFile = "c:\windows\fonts\SIMHEI.TTF"
Dim xlsSheet As Worksheet
Set xlsSheet = ReturnXlsSheet(1)
xlsSheet.Range("a:z").ClearContents
Dim LineData As AcadLine, ArcData As AcadArc
Dim DrawingText As AcadText, DrawingCircle As AcadCircle
Close #1
Open "D:\ls.txt" For Output As #1
Write #1, "m1", "m2", "m3", "m4", "m5", "m6", "m7", "m8", "m9", "m10", "m11", "m12"
Dim Ent As AcadEntity
'Debug.Print ThisDrawing.ModelSpace.Count
For ii = 1 To ThisDrawing.ModelSpace.Count
'm1 = Ent.ObjectName
Set Ent = ThisDrawing.ModelSpace.Item(ii - 1)
Debug.Print ii, Ent.ObjectName, Ent.Handle
m2 = Ent.ObjectID
Select Case Ent.ObjectName
Case "AcDbLine"
Set LineData = Ent
With LineData
'Set DrawingCircle = ThisDrawing.ModelSpace.AddCircle(.StartPoint, 35)
m1 = "第" & ii & "点"
If ii = 1 Then
m3 = Round(.StartPoint(0), 2)
m4 = Round(.StartPoint(1), 2)
Else
m3 = "=c" & ii - 1 & "+ i" & ii - 1
m4 = "=d" & ii - 1 & "+ j" & ii - 1
End If
m5 = Round(.StartPoint(2), 2)
'm6 = Round(.EndPoint(0), 2)
If ii = ThisDrawing.ModelSpace.Count Then
m6 = "=c1"
m7 = "=d1"
Else
m6 = "=c" & ii & "+ i" & ii
'm7 = Round(.EndPoint(1), 2)
m7 = "=d" & ii & "+ j" & ii
End If
m8 = Round(.EndPoint(2), 2)
m9 = .Delta(0)
m10 = .Delta(1)
m11 = .Delta(2)
ttt = "第" & ii & "点 " & "(" & m3 & "," & m4 & ")"
'Set DrawingText = ThisDrawing.ModelSpace.AddText(ttt, .EndPoint, 10)
With DrawingText
' .Alignment = acAlignmentMiddleCenter
' .TextAlignmentPoint = LineData.StartPoint
'ii = ii + 1
End With
End With
End Select
Write #1, m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11 ', m12
With xlsSheet
.Cells(ii, 1) = m1
.Cells(ii, 2) = m2
.Cells(ii, 3) = m3
.Cells(ii, 4) = m4
.Cells(ii, 5) = m5
.Cells(ii, 6) = m6
.Cells(ii, 7) = m7
.Cells(ii, 8) = m8
.Cells(ii, 9) = m9
.Cells(ii, 10) = m10
.Cells(ii, 11) = m11
End With
Next ii
Close #1
End Sub
Function ReturnXlsSheet(InputSheetNum As Integer) As Worksheet
Dim xlApp As Object ' This Line ,Not set Excel , run Excel
' 发生错误时跳到下一个语句继续执行
On Error Resume Next
' 连接Excel应用程序
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.Workbooks.Add
End If
' 返回当前活动的工作表
Set ReturnXlsSheet = xlApp.Sheets(InputSheetNum)
End Function
Sub gggg()
Dim xlsSheet As Worksheet
Set xlsSheet = ReturnXlsSheet(1)
Dim pp(0 To 2) As Double, ppp(0 To 2) As Double
Dim ll As AcadLine
For ii = 1 To 8
For jj = 0 To 2
pp(jj) = xlsSheet.Cells(ii, jj + 3)
ppp(jj) = xlsSheet.Cells(ii, jj + 6)
Next jj
Set ll = ThisDrawing.ModelSpace.AddLine(pp, ppp)
ll.color = ii
Next ii
End Sub
Sub ls()
Dim xlsSheet As Worksheet
Set xlsSheet = ReturnXlsSheet(1)
xlsSheet.Range("a:z").ClearContents
Dim EntCount As Integer
Dim Ent As AcadEntity, lineObj As AcadLine
EntCount = ThisDrawing.ModelSpace.Count
Dim mm() As Long
Dim Num As Integer
ReDim mm(EntCount - 2) As Long
Dim BaseStartPoint As Variant, BaseEndPoint As Variant
Num = 0
For ii = 0 To EntCount - 1
Set lineObj = ThisDrawing.ModelSpace(ii)
With lineObj
If .color = 200 Then
baseentity = .ObjectID
If .StartPoint(0) < .EndPoint(0) Then
BaseStartPoint = lineObj.StartPoint
BaseEndPoint = lineObj.EndPoint
Else
BaseStartPoint = lineObj.EndPoint
BaseEndPoint = lineObj.StartPoint
End If
For jj = 0 To 2
With xlsSheet
.Cells(2, jj + 1) = BaseStartPoint(jj)
.Cells(2, jj + 1 + 3) = BaseEndPoint(jj)
.Cells(2, 7) = "第1点"
End With
Next jj
Else
mm(Num) = lineObj.ObjectID
Num = Num + 1
End If
End With
Next ii
Dim mmm() As Long', ssmm As Long
ReDim mmm(EntCount - 2) As Long
nn = 3
For ii = 0 To EntCount - 2
'ssmm = mm(ii)
Num = 0
For jj = 0 To EntCount - 2
If baseentity <> mm(jj) Then
mmm(Num) = mm(jj)
Num = Num + 1
End If
Next jj
Dim llss As Variant
llss = InputPointData(BaseEndPoint, mmm)
BaseEndPoint = llss(1)
For jj = 0 To 2
With xlsSheet
.Cells(nn, jj + 1) = llss(0)(jj)
.Cells(nn, jj + 1 + 3) = llss(1)(jj)
.Cells(nn, 7) = "第" & nn - 1 & "点"
End With
Next jj
nn = nn + 1
Next ii
End Sub
Function InputPointData(InputPoint, InputArray) As Variant()
Dim Ent As AcadEntity, lineObj As AcadLine
Dim pp(1) As Variant, ppp(0 To 2) As Variant
For ii = 0 To UBound(InputArray)
Set lineObj = ThisDrawing.ObjectIdToObject(InputArray(ii))
If InputPoint(0) = lineObj.EndPoint(0) _
And InputPoint(1) = lineObj.EndPoint(1) _
And InputPoint(2) = lineObj.EndPoint(2) Then
pp(0) = lineObj.EndPoint
pp(1) = lineObj.StartPoint
InputPointData = pp
Exit Function
End If
If InputPoint(0) = lineObj.StartPoint(0) _
And InputPoint(1) = lineObj.StartPoint(1) _
And InputPoint(2) = lineObj.StartPoint(2) Then
pp(0) = lineObj.StartPoint
pp(1) = lineObj.EndPoint
InputPointData = pp
Exit Function
End If
Next ii
End Function
Function InputEntityReturnType(InputChar As Long, InputArray As Variant)
Dim Ent As AcadEntity, Ent1 As AcadEntity
Dim pp()
ReDim pp(UBound(InputArray) - 1)
Dim BaseCount As Integer
Set Ent = ThisDrawing.ObjectIdToObject(InputChar)
BaseCount = 0
For ii = 0 To UBound(InputArray)
Set Ent1 = ThisDrawing.ObjectIdToObject(InputArray(ii))
pp(BaseCount) = Ent.IntersectWith(Ent1, acExtendNone)
BaseCount = BaseCount + 1
Next ii
End Function
Sub DrawingCircle()
Dim xlsSheet As Worksheet
Set xlsSheet = ReturnXlsSheet(1)
Dim pp(0 To 2) As Double, ppp(0 To 2) As Double
Dim ll As AcadLine
Dim DefineCircle As AcadCircle, TextObj As AcadText
For ii = 2 To 6
For jj = 0 To 2
pp(jj) = xlsSheet.Cells(ii, jj + 1)
ppp(jj) = xlsSheet.Cells(ii, jj + 4)
Next jj
Set DefineCircle = ThisDrawing.ModelSpace.AddCircle(pp, 25)
Set TextObj = ThisDrawing.ModelSpace.AddText(ii - 1, pp, 20)
With TextObj
.Alignment = acAlignmentMiddleCenter
.TextAlignmentPoint = DefineCircle.Center
End With
DefineCircle.color = ii
Next ii
End Sub
页:
[1]