[分享]坡度标注程序

gzy

有个朋友要坡度标注的功能，所以帮他做了，感觉还是很顺利。
  现共享出来与大家分享。如果有更好的建议或者批评指正，欢迎提出。在此感谢

  源码如下：
'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) < 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

yezq

怎么用啊?????

gzy

呵呵，运行模块里的菜单，这时CAD菜单上就会有相应的菜单（最后一项）
  这时选择后就可以直接用了。

yezq

我是新手,文件下载了,但不知道放在哪??用法请说详细一点好吗?谢谢!

gzy

工具——宏——加载工程：选择下载的程序
然后ALT+F11。如下图所示，
把鼠标停留在中间那个框处运行

yezq

哦!谢谢
我试试^_^

hrdzz

按你的方法加载了，但用不了啊，急死了

gzy

怎么用不了？可能是你不懂怎么操作

subtlation

可以用了。不过有一个小问题。
使用“退出坡度标注程序”时把我自己做的所有菜单文件都自动卸载了。

gzy

呵呵，这个问题我也没有办法改进了。