[VBA程序]：坡度标注程序

guanzhangyang

'Email:gzy@mjtd.com
Public jd, h As Double
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()
Dim lineobj As AcadLine
Dim selobj As AcadObject, selpnt As Variant
Dim mp1(0 To 2) As Double
Dim mp2(0 To 2) As Double
RETRY:
On Error Resume Next
Do While code = 0
ThisDrawing.Utility.GetEntity selobj, selpnt, "请选择目标直线"
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
Else
Err.Clear
  End If
  Loop
Dim i As Double
i = (mp2(1) - mp1(1)) / (mp2(0) - mp1(0))
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(Str(i)), 1, jd + 2)
  textstring = "i=" & a
  Else
  a = Mid(LTrim(Str(i)), 1, jd + 1)
  textstring = "i=0" & a
  End If
Else
  If Abs(i) > 1 Then
    a = Mid(LTrim(Str(i)), 2, jd + 2)
    textstring = "i=" & a
  End If
  If Abs(i) < 1 Then
    a = Mid(LTrim(Str(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 selobj As AcadObject, selpnt As Variant
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, selpnt, "请选择目标直线"
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
Else
Err.Clear
  End If
  Loop
  On Error Resume Next
Do While code = 0
ThisDrawing.Utility.GetEntity selobj, selpnt, "请选择相对直线"
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
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(Str(i)), 1, jd + 2)
  textstring = "i=" & a
  Else
  a = Mid(LTrim(Str(i)), 1, jd + 1)
  textstring = "i=0" & a
  End If
Else
  If Abs(i) > 1 Then
    a = Mid(LTrim(Str(i)), 2, jd + 2)
    textstring = "i=" & a
  End If
  If Abs(i) < 1 Then
    a = Mid(LTrim(Str(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

Private Sub CommandButton1_Click()
UserForm1.Hide
jd = TextBox1.Text
h = TextBox2.Text
End Sub
Private Sub UserForm_Initialize()
'填写精度控制框的内容
TextBox1.Text = "2"
  TextBox2.Text = "5"
End Sub

山下一匹夫

66666666666666666666666666666