请教acad宏开发的问题

norlens

我做了一个vba宏

我现在用的是SendCommand来返回我需要的数据，我想象list命令一样，跳出一个窗口来返回我需要的数据，用什么方法？是否要调用一个txt窗口？

还有，我希望这个宏能够像line，list等cad内置的命令一样，输入一个词就能运行，该怎么设置？？

我查阅了一些acad自定义命令的书，可是我看不明白，希望有大师能不吝详细赐教！

jxh2003zfr

将宏用public声明

写一lisp如下

(defun C:命令名 ()
  (princ)
  (command "_.VBARUN" "thisdrawing.宏名");如果你的宏名是在thisdrawing中就用这句

  (command "_.VBARUN" "模组名.宏名");如果你的宏名是在Module中就用这句
;将以上宏名、模组名用相应的名字替换即可。
)

;加载这个lisp和dvb文件，输入命令名。

norlens

thanks a lot

不过不知道，vba怎么让command的文本窗口，像list命令一样可以弹出来并返回值？

jxh2003zfr

呵呵，像lisp一样弹出返回值，也可以
不过要写代码才行,举例说明:

3. public sub VBList()
4. ThisDrawing.Utility.GetEntity pickobj, pickpnt, "選擇圖元對象:"
5. nameobj = pickobj.ObjectName
6. lty = UCase(pickobj.Linetype)
7. lay = pickobj.Layer
8. color = pickobj.color
9. '當為Bylayer or Byblock線型時,找出相應的層的線型
10. If lty = "BYLAYER" Or lty = "BYBLOCK" Then
11.    Set layobj = ThisDrawing.Layers.Item(lay)
12.    lty = lty & "(" & layobj.Linetype & ")"
13. End If
15. Select Case nameobj
16.     Case "AcDbLine"
17.         
18.     Case "AcDbCircle"
19.         get_circle pickobj, lay, lty, color, appname
20.     Case "AcDbText", "AcDbMText"
21.     Case "AcDbArc"
22.     Case "AcDbBlockReference"
23.     Case "AcDbPolyline"
24. .......
25.     Case Else
26.         ThisDrawing.SendCommand "_.LIST" & vbCr & "(handent """ & pickobj.Handle & """)" & vbCr & vbCr
27.         Exit Sub
28. End Select
29. errordeal:
30. If Err.Number <> 0 Then
31. Err.Clear
32. Exit Sub
33. End If
34. end Sub
35. Private Function get_circle(ByVal pickobj As AcadEntity, ByVal lay As String, ByVal lty As String, ByVal color As String, ByVal appname As String)
36. Dim cenpnt As Variant, cirdia As Double
37. cenpnt = pickobj.Center
38. cenpnt = ThisDrawing.Utility.TranslateCoordinates(cenpnt, acWorld, acUCS, False)
39. cirdia = pickobj.Diameter
40. cenpnt(0) = Format(cenpnt(0), "0.0000")
41. cenpnt(1) = Format(cenpnt(1), "0.0000")
42. cenpnt(2) = Format(cenpnt(2), "0.0000")
43. cirdia = Format(cirdia, "0.000")
44. MsgBox "圖元名: Circle (圓)" & Chr(13) & Chr(13) & "圖層名: " & lay & Chr(13) & Chr(13) & "顏色號: " & color & _
45. Chr(13) & Chr(13) & "線型名: " & lty & Chr(13) & Chr(13) & "直徑值: " & cirdia & Chr(13) & Chr(13) & _
46. "圓心坐標點: " & "X= " & cenpnt(0) & ",Y= " & cenpnt(1) & ",Z= " & cenpnt(2) & Chr(13) & Chr(13)
47. End Function

public sub VBList() ThisDrawing.Utility.GetEntity pickobj, pickpnt, "選擇圖元對象:" nameobj = pickobj.ObjectName lty = UCase(pickobj.Linetype) lay = pickobj.Layer color = pickobj.color '當為Bylayer or Byblock線型時,找出相應的層的線型 If lty = "BYLAYER" Or lty = "BYBLOCK" Then    Set layobj = ThisDrawing.Layers.Item(lay)    lty = lty & "(" & layobj.Linetype & ")" End If Select Case nameobj     Case "AcDbLine"              Case "AcDbCircle"         get_circle pickobj, lay, lty, color, appname     Case "AcDbText", "AcDbMText"     Case "AcDbArc"     Case "AcDbBlockReference"     Case "AcDbPolyline" .......     Case Else         ThisDrawing.SendCommand "_.LIST" & vbCr & "(handent """ & pickobj.Handle & """)" & vbCr & vbCr         Exit Sub End Select errordeal: If Err.Number <> 0 Then Err.Clear Exit Sub End If end Sub Private Function get_circle(ByVal pickobj As AcadEntity, ByVal lay As String, ByVal lty As String, ByVal color As String, ByVal appname As String) Dim cenpnt As Variant, cirdia As Double cenpnt = pickobj.Center cenpnt = ThisDrawing.Utility.TranslateCoordinates(cenpnt, acWorld, acUCS, False) cirdia = pickobj.Diameter cenpnt(0) = Format(cenpnt(0), "0.0000") cenpnt(1) = Format(cenpnt(1), "0.0000") cenpnt(2) = Format(cenpnt(2), "0.0000") cirdia = Format(cirdia, "0.000") MsgBox "圖元名: Circle (圓)" & Chr(13) & Chr(13) & "圖層名: " & lay & Chr(13) & Chr(13) & "顏色號: " & color & _ Chr(13) & Chr(13) & "線型名: " & lty & Chr(13) & Chr(13) & "直徑值: " & cirdia & Chr(13) & Chr(13) & _ "圓心坐標點: " & "X= " & cenpnt(0) & ",Y= " & cenpnt(1) & ",Z= " & cenpnt(2) & Chr(13) & Chr(13) End Function

当然，你可以写更多function处理不同类型的图素。然后根据你所选择的图素类型再调用相应的function处理即可.

norlens

三楼大概没有测试你的程序，我刚学，不知道为什么当我运行的时候总会出现，编译错误，ByRef编译参数不符？

因为程序没有运行我不知道对不对，想知道你的方法是用list命令调出那个command窗口来写文字？

雪山飞狐_lzh

Sub tt()
    ThisDrawing.Utility.Prompt "嗯，好的"
    SendKeys "{F2}"
End Sub

做成命令调用，下面的代码放在acad.lsp文件中载入

(vl-load-com)

(defun c:tt() (vla-runmacro (vlax-get-acad-object) "tt") (princ))

norlens

6楼同志的方法简单，易懂，thanks！

xxxtttxxx

比如我vba放在路径c：\vba.dvb

命令名为“PP”，

在命令栏中输入pp，如果vba.dvb已经加载，则运行其中的函数，比如tt()

如果没有加载，则加载vba.dvb，运行tt().

请问如何实现？

雪山飞狐_lzh

(defun c:tt() (vla-runmacro (vlax-get-acad-object) "vba.dvb!tt") (princ))