[分享]：AutoCAD二次开发范例,qing cankao

liyanha

模块部分：
'2003.10.9
'by gzy
'Email:gzy@mjtd.com
Public jd, h As Double
Dim mp1(0 To 2) As Double
Dim mp2(0 To 2) As Double
Dim ppt As Variant
Dim sPt As Variant
Dim ePt As Variant
Dim selobj As AcadObject
Dim explodedObjects As Variant
Dim lineobj As AcadLine
Dim k As Integer
Sub mainmenu()
    Dim newmenu As AcadPopupMenu
    Dim newmenugroup As AcadMenuGroup
    Dim newmenuitemname As AcadPopupMenuItem
    Set newmenugroup = ThisDrawing.Application.MenuGroups.Item(0)
    Set newmenu = newmenugroup.Menus.Add("坡度标注")
    Set newmenuitemname = newmenu.AddMenuItem(newmenu.Count + 0, "相对X轴坡度", "-vbarun pd ")
    Set newmenuitemname = newmenu.AddMenuItem(newmenu.Count + 1, "相对指定直线坡度", "-vbarun rj ")
    Set newmenuitemname = newmenu.AddMenuItem(newmenu.Count + 2, "退出坡度标注程序", "-vbarun u2 ")
    newmenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)
End Sub
Sub u2()
    ThisDrawing.SendCommand "filedia 0 "
    ThisDrawing.SendCommand "menu " + Chr(13)
    ThisDrawing.SendCommand "filedia 1 "
End Sub
Sub pd()
RETRY:
    On Error Resume Next
     Do While code = 0
        ThisDrawing.Utility.GetEntity selobj, ppt, "请选择目标直线"
      If Err <> 0 Then
            Err.Clear
            ThisDrawing.Utility.Prompt " 没有选定对象,退出"
            Exit Sub
      End If
     If Err.Number = 0 Then
        If (selobj.EntityName = "AcDbLine") Then
            Set lineobj = selobj
            mp1(0) = lineobj.StartPoint(0)
            mp1(1) = lineobj.StartPoint(1)
            mp2(0) = lineobj.EndPoint(0)
            mp2(1) = lineobj.EndPoint(1)
        Exit Do
        End If
        If (selobj.EntityName = "AcDbPolyline") Then
            Call fj
            mp1(0) = lineobj.StartPoint(0)
            mp1(1) = lineobj.StartPoint(1)
            mp2(0) = lineobj.EndPoint(0)
            mp2(1) = lineobj.EndPoint(1)
            Exit Do
         End If
       Err.Clear
      End If
     Loop
    Dim i As Double
    y = mp2(1) - mp1(1)
    x = mp2(0) - mp1(0)
    'x = Left(Str(x), 1, 10)
    'y = Left(Str(y), 1, 10)
     i = y / x
    Dim a
    Dim textobj As AcadText
    Dim textstring As String
    Dim inspoint(0 To 2) As Double
    Dim textheight As Double
    UserForm1.Show
    If i > 0 Then
        If i > 1 Then
        a = Mid(LTrim(CDec(i)), 1, jd + 2)
        textstring = "i=" & a
        Else
        a = Mid(LTrim(CDec(i)), 1, jd + 1)
        textstring = "i=0" & a
        End If
    Else
        If Abs(i) > 1 Then
          a = Mid(LTrim(CDec(i)), 2, jd + 2)
          textstring = "i=" & a
        End If
        If Abs(i) < 1 Then
          a = Mid(LTrim(CDec(i)), 2, jd + 1)
          textstring = "i=0" & a
        End If
    End If
    Dim pin As Variant
    pin = ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入插入点:")
    inspoint(0) = pin(0)
    inspoint(1) = pin(1)
    inspoint(2) = pin(2)
    textheight = h    '此处可修改文字高度
     If i = 0 Then
       textstring = "i=0"
     End If
    Set textobj = ThisDrawing.ModelSpace.AddText(textstring, inspoint, textheight)
    Dim rotateangle As Double
    rotateangle = Atn(i)
    textobj.Rotate inspoint, rotateangle
    GoTo RETRY
End Sub
Sub rj()
    Dim lineobj(0 To 1) As AcadLine
    Dim mp1(0 To 2) As Double
    Dim mp2(0 To 2) As Double
    Dim mp3(0 To 2) As Double
    Dim mp4(0 To 2) As Double
RETRY:
     On Error Resume Next
     Do While code = 0
      ThisDrawing.Utility.GetEntity selobj, ppt, "请选择目标直线"
     If Err <> 0 Then
            Err.Clear
            ThisDrawing.Utility.Prompt " 没有选定对象,退出"
            Exit Sub
        End If
    If Err.Number = 0 Then
            If (selobj.EntityName = "AcDbLine") Then
             Set lineobj(0) = selobj
             mp1(0) = lineobj(0).StartPoint(0)
             mp1(1) = lineobj(0).StartPoint(1)
             mp2(0) = lineobj(0).EndPoint(0)
             mp2(1) = lineobj(0).EndPoint(1)
             Dim x1, y1, x2, y2 As Double
             x1 = mp2(0) - mp1(0)
             y1 = mp2(1) - mp1(1)
             Dim aha1, aha2 As Double
             aha1 = Atn(y1 / x1)
         Exit Do
        End If
        If (selobj.EntityName = "AcDbPolyline") Then
            Call fj
            Set lineobj(0) = explodedObjects(k)
            mp1(0) = lineobj(0).StartPoint(0)
            mp1(1) = lineobj(0).StartPoint(1)
            mp2(0) = lineobj(0).EndPoint(0)
            mp2(1) = lineobj(0).EndPoint(1)
            x1 = mp2(0) - mp1(0)
            y1 = mp2(1) - mp1(1)
            aha1 = Atn(y1 / x1)
          Exit Do
        End If
     Else
       Err.Clear
     End If
    Loop
    On Error Resume Next
    Do While code = 0
      ThisDrawing.Utility.GetEntity selobj, ppt, "请选择相对直线"
       If Err <> 0 Then
            Err.Clear
            ThisDrawing.Utility.Prompt " 没有选定对象,退出"
            Exit Sub
       End If
       If Err.Number = 0 Then
             If (selobj.EntityName = "AcDbLine") Then
              Set lineobj(1) = selobj
              mp3(0) = lineobj(1).StartPoint(0)
              mp3(1) = lineobj(1).StartPoint(1)
              mp4(0) = lineobj(1).EndPoint(0)
              mp4(1) = lineobj(1).EndPoint(1)
              x2 = mp4(0) - mp3(0)
              y2 = mp4(1) - mp3(1)
              aha2 = Atn(y2 / x2)
              Exit Do
             End If
      If (selobj.EntityName = "AcDbPolyline") Then
         Call fj
                Set lineobj(1) = explodedObjects(k)
                mp3(0) = lineobj(1).StartPoint(0)
                mp3(1) = lineobj(1).StartPoint(1)
                mp4(0) = lineobj(1).EndPoint(0)
                mp4(1) = lineobj(1).EndPoint(1)
                x2 = mp4(0) - mp3(0)
                y2 = mp4(1) - mp3(1)
                aha2 = Atn(y2 / x2)
           Exit Do
       End If
     Else
       Err.Clear
     End If
      Loop
    Dim i As Double
    i = Tan(aha1 - aha2)
    Dim a
    Dim textobj As AcadText
    Dim textstring As String
    Dim inspoint(0 To 2) As Double
    Dim textheight As Double
    UserForm1.Show
    If i > 0 Then
        If i > 1 Then
            a = Mid(LTrim(CDec(i)), 1, jd + 2)
            textstring = "i=" & a
        Else
            a = Mid(LTrim(CDec(i)), 1, jd + 1)
            textstring = "i=0" & a
        End If
    Else
        If Abs(i) > 1 Then
            a = Mid(LTrim(CDec(i)), 2, jd + 2)
            textstring = "i=" & a
        End If
        If Abs(i) < 1 Then
            a = Mid(LTrim(CDec(i)), 2, jd + 1)
            textstring = "i=0" & a
        End If
    End If
    Dim pin As Variant
    pin = ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入插入点:")
    inspoint(0) = pin(0)
    inspoint(1) = pin(1)
    inspoint(2) = pin(2)
    textheight = h
        If i = 0 Then
          textstring = "i=0"
        End If
    Set textobj = ThisDrawing.ModelSpace.AddText(textstring, inspoint, textheight)
    Dim rotateangle As Double
    rotateangle = Atn(y1 / x1)
    textobj.Rotate inspoint, rotateangle
    GoTo RETRY
End Sub
Sub fj()
   explodedObjects = selobj.Explode          '炸开
        selobj.Delete
        Dim EntObj As AcadEntity
        For k = 0 To UBound(explodedObjects)   '判断选择点是否位于直线两端点的X坐标和Y坐标之内
                                               '一般情况下这种方法是可行的，对于特殊情况未做判断
            sPt = explodedObjects(k).StartPoint
            ePt = explodedObjects(k).EndPoint
            If (ppt(0) > sPt(0) And ppt(0) < ePt(0)) Or (ppt(0) > ePt(0) And ppt(0) < sPt(0)) Then
                If (ppt(1) > sPt(1) And ppt(1) < ePt(1)) Or (ppt(1) > ePt(1) And ppt(1) < sPt(1)) Then
                    Set lineobj = explodedObjects(k)
                   Exit For
                End If
            End If
        Next
        If Not (EntObj Is Nothing) Then
            Debug.Print "距选择点最近的直线: " & EntObj.Handle
        End If
End Sub

窗体：
Private Sub CommandButton1_Click()
UserForm1.Hide
jd = TextBox1.Text
h = TextBox2.Text
End Sub

Private Sub UserForm_Initialize()
'填写精度控制框的内容
  TextBox1.Text = ThisDrawing.GetVariable("dimdec") '按系统设置小数精度
  TextBox2.Text = ThisDrawing.GetVariable("dimtxt") '按系统设置文字高度
End Sub
[ 点击下载 ]


*-*1

bruce_hui

在下佩服