乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 49|回复: 2

『求助』菜单怎样调用子程序(宏)?

[复制链接]

13

主题

121

帖子

10

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
173
发表于 2009-12-27 11:40:00 | 显示全部楼层 |阅读模式
本人刚接触CAD的VBA,现在遇到一个问题想请教各位老师:
问题:我编辑了一个程序Sub ysdmx(),和一个自己的菜单,我想通过菜单控制子程序,但是实现不了,
命令行中显示
命令: _ysdmx
未知命令“YSDMX”。按 F1 查看帮助。
菜单:

qq1wbl0p12s.JPG

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
回复

使用道具 举报

72

主题

2726

帖子

9

银币

社区元老

Rank: 75Rank: 75Rank: 75

铜币
3014
发表于 2009-12-27 20:31:00 | 显示全部楼层
"_ysdmx" => "-vbarun ysdmx"
回复

使用道具 举报

13

主题

121

帖子

10

银币

初露锋芒

Rank: 3Rank: 3Rank: 3

铜币
173
发表于 2009-12-28 10:18:00 | 显示全部楼层

经过你的指点,调试成功,非常感谢!
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-7-1 19:45 , Processed in 1.232432 second(s), 72 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表