[分享]坡度标注程序

gzy · 发表于 2003-11-9 21:30:00

有个朋友要坡度标注的功能，所以帮他做了，感觉还是很顺利。
  现共享出来与大家分享。如果有更好的建议或者批评指正，欢迎提出。在此感谢
  源码如下：
'2003.10.9
'by gzy
'www.mjtd.com
'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)  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)

lz4bo0rdfwc.jpg

ihrkr5212ha.jpg