练手示例：给每个直线顶点加序号

兰州人 · 发表于 2008-6-25 12:12:00

本帖最后由作者于 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

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

方法1

Sub 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

Sub 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

tl319 · 发表于 2008-6-25 14:13:00

取每个端点的坐标,并输出!

兰州人 · 发表于 2008-6-29 09:20:00

以下程序将点送到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

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

账号		自动登录	找回密码
密码			注册

练手示例：给每个直线顶点加序号

本帖子中包含更多资源

浏览过的版块