怎么在autocad 命令栏中 调用dvb程序？

buhuilang

我按照cad帮助里编辑了一下gardenpath的程序，在vb编辑器中点击运行，可以在cad绘图窗口使用。但是我想把它作为一个程序，就像调用line一样，在命令栏中输入‘line’即可花直线。高手指点一下。我加载过，但是加载完老说，没有此（gardenpath）命令

源码：

Const pi = 3.14159

Private sp(0 To 2) As Double
Private ep(0 To 2) As Double
Private hwidth As Double
Private trad As Double
Private tspac As Double
Private pangle As Double
Private plength As Double
Private totalwidth As Double
Private angp90 As Double
Private angm90 As Double

' 将角度从度转换为弧度
Function dtr(a As Double) As Double
    dtr = (a / 180) * pi
End Function

' 计算两点之间距离
Function distance(sp As Variant, ep As Variant) _
 As Double
    Dim x As Double
    Dim y As Double
    Dim z As Double
    x = sp(0) - ep(0)
    y = sp(1) - ep(1)
    z = sp(2) - ep(2)
    distance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function

' 获取花园小路的信息
Private Sub gpuser()
    Dim varRet As Variant
    varRet = ThisDrawing.Utility.GetPoint( _
     , "Start point of path: ")
    sp(0) = varRet(0)
    sp(1) = varRet(1)
    sp(2) = varRet(2)
    varRet = ThisDrawing.Utility.GetPoint( _
     , "Endpoint of path: ")
    ep(0) = varRet(0)
    ep(1) = varRet(1)
    ep(2) = varRet(2)
    hwidth = ThisDrawing.Utility. _
     GetDistance(sp, "Half width of path: ")
    trad = ThisDrawing.Utility. _
     GetDistance(sp, "Radius of tiles: ")
    tspac = ThisDrawing.Utility. _
     GetDistance(sp, "Spacing between tiles: ")
    pangle = ThisDrawing.Utility.AngleFromXAxis( _
     sp, ep)
    totalwidth = 2 * hwidth
    plength = distance(sp, ep)
    angp90 = pangle + dtr(90)
    angm90 = pangle - dtr(90)
End Sub

' 绘制路的轮廓
Private Sub drawout()
    Dim points(0 To 9) As Double
    Dim pline As AcadLWPolyline
    Dim varRet As Variant
    varRet = ThisDrawing.Utility.PolarPoint( _
        sp, angm90, hwidth)
    points(0) = varRet(0)
    points(1) = varRet(1)
    points(8) = varRet(0)
    points(9) = varRet(1)
    varRet = ThisDrawing.Utility.PolarPoint( _
        varRet, pangle, plength)
    points(2) = varRet(0)
    points(3) = varRet(1)
    varRet = ThisDrawing.Utility.PolarPoint( _
        varRet, angp90, totalwidth)
    points(4) = varRet(0)
    points(5) = varRet(1)
    varRet = ThisDrawing.Utility.PolarPoint( _
        varRet, pangle + dtr(180), plength)
    points(6) = varRet(0)
    points(7) = varRet(1)
    Set pline = ThisDrawing.ModelSpace. _
     AddLightWeightPolyline(points)
End Sub

' 按沿小路的给定距离放置一行瓷砖
' 并且可能需要偏移
Private Sub drow(pd As Double, offset As Double)
    Dim pfirst(0 To 2) As Double
    Dim pctile(0 To 2) As Double
    Dim pltile(0 To 2) As Double
    Dim cir As AcadCircle
    Dim varRet As Variant
    varRet = ThisDrawing.Utility.PolarPoint( _
     sp, pangle, pd)
    pfirst(0) = varRet(0)
    pfirst(1) = varRet(1)
    pfirst(2) = varRet(2)
    varRet = ThisDrawing.Utility.PolarPoint( _
     pfirst, angp90, offset)
    pctile(0) = varRet(0)
    pctile(1) = varRet(1)
    pctile(2) = varRet(2)
    pltile(0) = pctile(0)
    pltile(1) = pctile(1)
    pltile(2) = pctile(2)
    Do While distance(pfirst, pltile) < (hwidth - trad)
        Set cir = ThisDrawing.ModelSpace.AddCircle( _
         pltile, trad)
        varRet = ThisDrawing.Utility.PolarPoint( _
         pltile, angp90, (tspac + trad + trad))
        pltile(0) = varRet(0)
        pltile(1) = varRet(1)
        pltile(2) = varRet(2)
    Loop
    varRet = ThisDrawing.Utility.PolarPoint( _
     pctile, angm90, tspac + trad + trad)
    pltile(0) = varRet(0)
    pltile(1) = varRet(1)
    pltile(2) = varRet(2)
    Do While distance(pfirst, pltile) < (hwidth - trad)
        Set cir = ThisDrawing.ModelSpace.AddCircle( _
         pltile, trad)
        varRet = ThisDrawing.Utility.PolarPoint( _
         pltile, angm90, (tspac + trad + trad))
        pltile(0) = varRet(0)
        pltile(1) = varRet(1)
        pltile(2) = varRet(2)
    Loop
End Sub
' 绘制每行瓷砖
Private Sub drawtiles()
    Dim pdist As Double
    Dim offset As Double
    pdist = trad + tspac
    offset = 0
    Do While pdist <= (plength - trad)
        drow pdist, offset
        pdist = pdist + ((tspac + trad + trad) * Sin(dtr(60)))
        If offset = 0 Then
            offset = (tspac + trad + trad) * Cos(dtr(60))
        Else
            offset = 0
        End If
    Loop
End Sub

' 执行命令，调用各个函数
Sub gardenpath()
    Dim sblip As Variant
    Dim scmde As Variant
    gpuser
    sblip = ThisDrawing.GetVariable("blipmode")
    scmde = ThisDrawing.GetVariable("cmdecho")
    ThisDrawing.SetVariable "blipmode", 0
    ThisDrawing.SetVariable "cmdecho", 0
    drawout
    drawtiles
    ThisDrawing.SetVariable "blipmode", sblip
    ThisDrawing.SetVariable "cmdecho", scmde
End Sub

azjmjsj

Private Sub addcommand()
ThisDrawing.SendCommand "(defun C:gp()(vl-vbarun " & Chr$(34) & "gardenpath" & Chr$(34) & "))" & Chr$(13)
End Sub

Private Sub AcadDocument_BeginCommand(ByVal CommandName As String)
If StrComp(Left$(CommandName, 3), "VBA", 1) <> 0 And UCase$(CommandName) <> "APPLOAD" Then Exit Sub
addcommand
End Sub

Private Sub AcadDocument_EndCommand(ByVal CommandName As String)
If StrComp(Left$(CommandName, 3), "VBA", 1) <> 0 And UCase$(CommandName) <> "APPLOAD" Then Exit Sub
addcommand
End Sub

Sub gardenpath()
    Dim sblip As Variant
    Dim scmde As Variant
    gpuser
    sblip = ThisDrawing.GetVariable("blipmode")
    scmde = ThisDrawing.GetVariable("cmdecho")
    ThisDrawing.SetVariable "blipmode", 0
    ThisDrawing.SetVariable "cmdecho", 0
    drawout
    drawtiles
    ThisDrawing.SetVariable "blipmode", sblip
    ThisDrawing.SetVariable "cmdecho", scmde
End Sub

快捷命令为：gp

****************************************************************************
西北凡人: http://www.abofanyi.com/blog