|
本人刚接触CAD的VBA,现在遇到一个问题想请教各位老师:
问题:我编辑了一个程序Sub ysdmx(),和一个自己的菜单,我想通过菜单控制子程序,但是实现不了,
命令行中显示
命令: _ysdmx
未知命令“YSDMX”。按 F1 查看帮助。
菜单:
qq1wbl0p12s.JPG
程序:
看看红色部分是不是 问题,有错误帮我指出来,还请帮忙修改一下。
菜单程序:
Option Explicit
Sub AddASubMenu()
'获得当前的菜单组***********************************************************************************
Dim currMenuGroup As AcadMenuGroup
Set currMenuGroup = ThisDrawing.Application.MenuGroups.Item(0)
' 创建新菜单
Dim newMenu As AcadPopupMenu
Set newMenu = currMenuGroup.Menus.Add("武赤公路" & Chr(Asc("&")) & "u")
'添加菜单项*****************************************************************************************
Dim ysdmxmacro As String
ysdmxmacro = Chr(vbKeyEscape) + Chr(vbKeyEscape) '相当于按下两次Esc键
'open
Dim menuItemysdmx As AcadPopupMenuItem
Set menuItemysdmx = newMenu.AddMenuItem(newMenu.Count + 1, Chr(Asc("&")) & "绘地面线", ysdmxmacro & "_ysdmx")
newMenu.InsertInMenuBar (ThisDrawing.Application.MenuBar.Count + 1)
End Sub
模块程序
Sub ysdmx()
Dim layerObj As AcadLayer '注记层
Set layerObj = ThisDrawing.Layers.Add("原始地面线")
layerObj.color = acGreen
Dim p1 As Variant '申明端点坐标
Dim p2 As Variant
Dim l() As Double '声明一个动态数组
Dim A As Double
Dim c As Double
Dim Pline As Double
c = ThisDrawing.Utility.GetReal("绘地面线:") '用户选择绘图方式
If c = 1 Then
p1 = ThisDrawing.Utility.GetPoint(, "输入点:") '获取点坐标
ReDim l(0 To 2) '定义动态数组
l(0) = p1(0)
l(1) = p1(1)
l(2) = 0
On Error GoTo Err_Control '出错陷井
Do '开始循环
p2 = ThisDrawing.Utility.GetPoint(p1, vbCr & "输入下一点:") '获取下一个点的坐标
lub = UBound(l) '获取当前l数组中元的元素个数
ReDim Preserve l(lub + 3)
For i = 1 To 3
l(lub + i) = p2(i - 1)
Next i
Set PolylineObj = ThisDrawing.ModelSpace.AddPolyline(l) '画多段线
p1 = p2 '将第二点的端点保存为下一条直线的第一个端点坐标
PolylineObj.Layer = "原始地面线"
Loop
Else
p1 = ThisDrawing.Utility.GetPoint(, "输入点:") '获取点坐标
H = ThisDrawing.Utility.GetReal("输入该点高程值:") '用户输入输入该点高程值
A = ThisDrawing.Utility.GetReal("输入文字大小:") '用户输入输入绘图比例
'高程插入文字
Dim textObj As AcadText
Dim textString As String
Dim insertionPoint(0 To 2) As Double
Dim height As Double
Dim h1 As Double '声明变量h1“相对高程”
' 定义 Text 对象
textString = "(" & H & ")" '书写文字
insertionPoint(0) = p1(0) '文字插入点X坐标
insertionPoint(1) = p1(1) + 0.1
insertionPoint(2) = 0
height = A '文字高度
' 在模型空间中创建 Text 对象
Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height) '插入文字
textObj.Layer = "原始地面线" '将文字归入原始地面线图层
textObj.Update
ReDim l(0 To 2) '定义动态数组
l(0) = p1(0)
l(1) = p1(1)
l(2) = z
On Error GoTo Err_Control '出错陷井
Do '开始循环
p2 = ThisDrawing.Utility.GetPoint(p1, vbCr & "输入下一点:") '获取下一个点的坐标
h1 = Format(H + p2(1) - p1(1), "####0.00") '高程保留两位小数
H = h1
textString = "(" & h1 & ")"
insertionPoint(0) = p2(0)
insertionPoint(1) = p2(1) + 0.2
insertionPoint(2) = 0
' 在模型空间中创建 Text 对象
Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height)
textObj.Layer = "原始地面线" '将多段线归入原始地面线图层
textObj.Update
lub = UBound(l) '获取当前l数组中元的元素个数
ReDim Preserve l(lub + 3)
For i = 1 To 3
l(lub + i) = p2(i - 1)
Next i
Set PolylineObj = ThisDrawing.ModelSpace.AddPolyline(l) '画多段线
p1 = p2 '将第二点的端点保存为下一条直线的第一个端点坐标
PolylineObj.Layer = "原始地面线" '将多段线归属到原始地面线上
Loop
End If
Err_Control:
End Sub
|
|