请教一下，这个vba程序如何加载到cad中并运行，命令是什么？（初学）

tianyuan

Type JZDINFO
  DH As String
  x As String
  y As String
End Type

Public Sub InsertJZDCGB_Batch_Run()
On Error GoTo errhdl
  Dim pType, pData
  BuildFilter pType, pData, 0, "LWPOLYLINE", 8, "JZD"

  Dim sset As AcadSelectionSet
  Set sset = CreateSelectionSet

  sset.Select acSelectionSetAll, , , pType, pData
  Dim pInsPt As Variant
  pInsPt = ThisDrawing.Utility.GetPoint(, vbCr & "请确定界址点成果表的插入点：")

  ThisDrawing.Utility.Prompt vbCr & "请选择宗地："
  sset.Clear
  sset.SelectOnScreen pType, pData
  Dim pEnt As AcadLWPolyline
  Dim gType, gData
  Dim TmpTxtObj As AcadText
  For Each pEnt In sset
   pInsPt(1) = pInsPt(1) - 300  '300为成果表之间的间距

   '批量处理界址点成果表
   InsertJZDCGB_Run pEnt, pInsPt
  
  
  Next pEnt
errhdl:
  Select Case Err.Number
    Case 0
    Case Else
      If Not pEnt Is Nothing Then
       Debug.Print pEnt.Handle
      End If
      MsgBox "错误：" & Err.Description & "(" & Err.Number & ")"
  End Select
End Sub
'——————————————————————————————————————
'名称：InsertJZDCGB_Run
'作者：罗简单
'日期：2008-9-4
'功能：从宗地最左上角顺时针读取界址点的成果表
'——————————————————————————————————————
Public Sub InsertJZDCGB_Run(pEnt As AcadLWPolyline, pInsPt As Variant)
On Error GoTo errhdl
'  Dim pInsPt As Variant
'  pInsPt = ThisDrawing.Utility.GetPoint(, vbCr & "请确定界址点成果表的插入点：")
  Dim strName As String
  strName = "XA_ZD_JZDCGB"

'  Dim pEnt As AcadLWPolyline 'AcadEntity
'  Dim varPt As Variant
'  ThisDrawing.Utility.GetEntity pEnt, varPt, vbCr & "请选择宗地："
  Dim gType, gData
  Dim strQLR As String, strDJH As String, strDLH As String
  Dim strTF As String, dblArea_M1 As Double, dblArea_M2 As Double
  '取得权利人、地籍号、地类号
  pEnt.GetXData "South", gType, gData
  strDJH = gData(2): strQLR = gData(3): strDLH = gData(4)
  '取得所在图幅号
  pEnt.GetXData "TUFU", gType, gData
  If VarType(gType) = vbEmpty Then
    MsgBox "请设置宗地的所在图幅", vbInformation, "界址点成果表"
    'With ThisDrawing
    '  .SendCommand "SETJIEZHI "
    'End With
    'Dim strCmd As String
    'strCmd = "(Handent""" & pEnt.Handle & """)"

'   ThisDrawing.SendCommand strCmd & " "

    Exit Sub
  End If
  strTF = gData(1)
  '取得面积（平方米和亩）
  '1平方米=0.0015亩
  dblArea_M1 = Format(pEnt.Area, "0.000")
  dblArea_M2 = Format(dblArea_M1 * 0.0015, "0.000")

  '取得多段线顶点的个数
  Dim numVer As Integer
  numVer = (UBound(pEnt.Coordinates) + 1) / 2

  '共多少页，第几页
  Dim intTotalPage As Integer
  Dim k As Integer
  k = Int(numVer / 20)
  Dim n As Integer
  n = numVer Mod 20
  If n = 0 Then
    intTotalPage = k
  Else
    intTotalPage = k + 1
  End If
  '插入界址点成果表
  InsertJZDCGB pInsPt, strName

  '图表左上角坐标
  Dim tblLeftTop As Variant
  tblLeftTop = pInsPt
  tblLeftTop(1) = tblLeftTop(1) + 219.825 '219.824是表的高

  '插入第几页，共几页
  '*******************************************************
  Dim dblHG As Double
  dblHG = 8.485  '行高

  Dim tmpPt As Variant
  Dim TmpTxtObj As AcadText
  tmpPt = tblLeftTop
  tmpPt(0) = tmpPt(0) + 137
  tmpPt(1) = tmpPt(1) - 5.4
  InsertTxt TmpTxtObj, "1", tmpPt, 3, "TK"  '第1页

  tmpPt = TmpTxtObj.InsertionPoint
  tmpPt(1) = tmpPt(1) - dblHG

  InsertTxt TmpTxtObj, Trim(str(intTotalPage)), tmpPt, 3, "TK" '共几页
  '*******************************************************

  '开始插入基本信息（权利人、地籍号、地类号、所在图幅、面积）
  '*******************************************************
  '权利人
  tmpPt = tblLeftTop
  tmpPt(0) = tmpPt(0) + 32.793
  tmpPt(1) = tmpPt(1) - 23.687
  InsertTxt TmpTxtObj, strQLR, tmpPt, 3, "TK"

  '地籍号
  tmpPt = TmpTxtObj.InsertionPoint
  tmpPt(1) = tmpPt(1) - dblHG
  InsertTxt TmpTxtObj, strDJH, tmpPt, 3, "TK"

  '地类号
  tmpPt = TmpTxtObj.InsertionPoint
  tmpPt(0) = tmpPt(0) + 102
  InsertTxt TmpTxtObj, "0" & strDLH, tmpPt, 3, "TK"

  '所在图幅
  tmpPt = tblLeftTop
  tmpPt(0) = tmpPt(0) + 32.793
  tmpPt(1) = tmpPt(1) - 40.228
  InsertTxt TmpTxtObj, strTF, tmpPt, 3, "TK"

  '面积
  tmpPt = TmpTxtObj.InsertionPoint
  tmpPt(0) = tmpPt(0) + 62.152
  InsertTxt TmpTxtObj, Trim(str(dblArea_M1)), tmpPt, 3, "TK"  '平方米

  tmpPt = TmpTxtObj.InsertionPoint
  tmpPt(0) = tmpPt(0) + 42.05
  InsertTxt TmpTxtObj, Trim(str(dblArea_M2)), tmpPt, 3, "TK" '亩
  '*******************************************************

  '年月日
  '*******************************************************
  tmpPt = pInsPt
  tmpPt(0) = tmpPt(0) + 107.881
  tmpPt(1) = tmpPt(1) - 10.925
  InsertTxt TmpTxtObj, Trim(Year(Now)), tmpPt, 3, "TK"  '年

  tmpPt = TmpTxtObj.InsertionPoint
  tmpPt(0) = tmpPt(0) + 21.3
  InsertTxt TmpTxtObj, Trim(Month(Now)), tmpPt, 3, "TK" '月

  tmpPt = TmpTxtObj.InsertionPoint
  tmpPt(0) = tmpPt(0) + 13.6
  tmpPt(1) = tmpPt(1) - 0.6
  InsertTxt TmpTxtObj, Trim(Day(Now)), tmpPt, 3, "TK" '日
  '*******************************************************
   
  '如果页数不止一页，则插入附页
  '插入附页的同时，将附页基本信息填上
  '基本信息如：共多少页、第几页、权利人、地籍号、地类号、年月日
  '************************************************************
  Dim i As Integer
  Dim pInsPt_follow As Variant
  pInsPt_follow = pInsPt
  If intTotalPage > 1 Then
    For i = 2 To intTotalPage
      strName = "XA_ZD_JZDCGB1"
      pInsPt_follow(0) = pInsPt_follow(0) + 200
      InsertJZDCGB pInsPt_follow, strName
     
      tblLeftTop = pInsPt_follow
      tblLeftTop(1) = tblLeftTop(1) + 219.825 '219.824是表的高
     
      tmpPt = tblLeftTop
      tmpPt(0) = tmpPt(0) + 137
      tmpPt(1) = tmpPt(1) - 5.4
      InsertTxt TmpTxtObj, Trim(str(i)), tmpPt, 3, "TK"  '第几页

      tmpPt = TmpTxtObj.InsertionPoint
      tmpPt(1) = tmpPt(1) - dblHG

      InsertTxt TmpTxtObj, Trim(str(intTotalPage)), tmpPt, 3, "TK" '共几页
     
      '权利人
      tmpPt = tblLeftTop
      tmpPt(0) = tmpPt(0) + 32.793
      tmpPt(1) = tmpPt(1) - 23.687
      InsertTxt TmpTxtObj, strQLR, tmpPt, 3, "TK"

      '地籍号
      tmpPt = TmpTxtObj.InsertionPoint
      tmpPt(1) = tmpPt(1) - dblHG
      InsertTxt TmpTxtObj, strDJH, tmpPt, 3, "TK"

      '地类号
      tmpPt = TmpTxtObj.InsertionPoint
      tmpPt(0) = tmpPt(0) + 102
      InsertTxt TmpTxtObj, "0" & strDLH, tmpPt, 3, "TK"

        '年月日
      '*******************************************************
      tmpPt = pInsPt_follow
      tmpPt(0) = tmpPt(0) + 107.881
      tmpPt(1) = tmpPt(1) - 10.925
      InsertTxt TmpTxtObj, Trim(Year(Now)), tmpPt, 3, "TK"  '年

      tmpPt = TmpTxtObj.InsertionPoint
      tmpPt(0) = tmpPt(0) + 21.3
      InsertTxt TmpTxtObj, Trim(Month(Now)), tmpPt, 3, "TK" '月

      tmpPt = TmpTxtObj.InsertionPoint
      tmpPt(0) = tmpPt(0) + 13.6
      tmpPt(1) = tmpPt(1) - 0.6
      InsertTxt TmpTxtObj, Trim(Day(Now)), tmpPt, 3, "TK" '日
  '*******************************************************
    Next i
  End If
  '************************************************************


  '将界址点坐标信息输出到指定文本中
  ReadJZDINFO_To_Txt pEnt

  '插入界址点的信息
  '*******************************************************
  InsertJZD_Info TmpTxtObj, pInsPt, tmpPt
  '*******************************************************

  '从硬盘中删除坐标文件
  Kill "C:\JZDCGB.txt"

'Exit Sub  '退出过程
errhdl:
  Select Case Err.Number
    Case 0
    Case Else
      MsgBox "错误：" & Err.Description & "(" & ")"
  End Select
End Sub
'——————————————————————————————————————
'名称：InsertJZD_Info
'作者：罗简单
'日期：2008-9-6
'功能：读取界址点坐标文件到图上
'——————————————————————————————————————
Public Sub InsertJZD_Info(TmpTxtObj As AcadText, pInsPt As Variant, tmpPt As Variant)
  '判断坐标文件有多少行
  Dim i As Integer
  Dim totalRow As Integer
  Dim strFile As String
  strFile = "C:\JZDCGB.txt"
  totalRow = CreateObject("Scripting.FileSystemObject").OpenTextFile(strFile, 8).Line

  Dim myJZD As JZDINFO
  Dim myJZD1 As JZDINFO
  Dim strJZDInfo As String
  Dim varJZDInfo As Variant
  Dim dblDis As Double
  Dim Jzd_InsPt As Variant
   
  '如果总行数大于20行，则执行大于20行的内容
  If totalRow > 20 Then GoTo HereIsBiggerThan20
   
  Jzd_InsPt = pInsPt
  Jzd_InsPt(0) = Jzd_InsPt(0) + 6.612
  Jzd_InsPt(1) = Jzd_InsPt(1) + 162.033 + 8.485

  '循环文件
  For i = 1 To totalRow - 1
    tmpPt = Jzd_InsPt
    tmpPt(1) = Jzd_InsPt(1) - i * 8.485
   
    strJZDInfo = ReadFileLine(strFile, i)
    varJZDInfo = Split(strJZDInfo, ",")
    With myJZD
      .DH = varJZDInfo(0)
      .x = varJZDInfo(1)
      .y = varJZDInfo(2)
    End With
   
    If i <> totalRow - 1 Then
      strJZDInfo = ReadFileLine(strFile, i + 1)
      varJZDInfo = Split(strJZDInfo, ",")
      With myJZD1
        .DH = varJZDInfo(0)
        .x = varJZDInfo(1)
        .y = varJZDInfo(2)
      End With
     
      dblDis = Distance(myJZD.x, myJZD1.x, myJZD.y, myJZD1.y)
    End If
   
    If i <> totalRow - 1 Then
      InsertTxt TmpTxtObj, Trim(str(i)), tmpPt, 3, "TK"  '序号
    Else
      InsertTxt TmpTxtObj, "1", tmpPt, 3, "TK"  '序号
    End If
   
    tmpPt = TmpTxtObj.InsertionPoint
    tmpPt(0) = tmpPt(0) + 19.603
    InsertTxt TmpTxtObj, Trim(myJZD.DH), tmpPt, 3, "TK" '点号
   
    tmpPt = TmpTxtObj.InsertionPoint
    tmpPt(0) = tmpPt(0) + 24.002
    InsertTxt TmpTxtObj, Trim(myJZD.x), tmpPt, 3, "TK" 'X坐标
   
    tmpPt = TmpTxtObj.InsertionPoint
    tmpPt(0) = tmpPt(0) + 37.976
    InsertTxt TmpTxtObj, Trim(myJZD.y), tmpPt, 3, "TK" 'Y坐标
   
    If i <> totalRow - 1 Then
      tmpPt = TmpTxtObj.InsertionPoint
      tmpPt(0) = tmpPt(0) + 40.417
      tmpPt(1) = tmpPt(1) - 4.296
      InsertTxt TmpTxtObj, Format(dblDis, "0.00"), tmpPt, 3, "TK" '边长
    End If
  Next i
'总行数小于20行，执行完后则从这里退出
Exit Sub
HereIsBiggerThan20:
  '总行数大于20行
  '先读取前20行
  Jzd_InsPt = pInsPt
  Jzd_InsPt(0) = Jzd_InsPt(0) + 6.612
  Jzd_InsPt(1) = Jzd_InsPt(1) + 162.033 + 8.485

  '循环文件
  For i = 1 To 20
    tmpPt = Jzd_InsPt
    tmpPt(1) = Jzd_InsPt(1) - i * 8.485
   
    strJZDInfo = ReadFileLine(strFile, i)
    varJZDInfo = Split(strJZDInfo, ",")
    With myJZD
      .DH = varJZDInfo(0)
      .x = varJZDInfo(1)
      .y = varJZDInfo(2)
    End With
     
    strJZDInfo = ReadFileLine(strFile, i + 1)
    varJZDInfo = Split(strJZDInfo, ",")
    With myJZD1
      .DH = varJZDInfo(0)
      .x = varJZDInfo(1)
      .y = varJZDInfo(2)
    End With
     
    dblDis = Distance(myJZD.x, myJZD1.x, myJZD.y, myJZD1.y)
   
    InsertTxt TmpTxtObj, Trim(str(i)), tmpPt, 3, "TK"  '序号
   
    tmpPt = TmpTxtObj.InsertionPoint
    tmpPt(0) = tmpPt(0) + 19.603
    InsertTxt TmpTxtObj, Trim(myJZD.DH), tmpPt, 3, "TK" '点号
   
    tmpPt = TmpTxtObj.InsertionPoint
    tmpPt(0) = tmpPt(0) + 24.002
    InsertTxt TmpTxtObj, Trim(myJZD.x), tmpPt, 3, "TK" 'X坐标
   
    tmpPt = TmpTxtObj.InsertionPoint
    tmpPt(0) = tmpPt(0) + 37.976
    InsertTxt TmpTxtObj, Trim(myJZD.y), tmpPt, 3, "TK" 'Y坐标
    tmpPt = TmpTxtObj.InsertionPoint
    tmpPt(0) = tmpPt(0) + 40.417
    tmpPt(1) = tmpPt(1) - 4.296
    If i <> 20 Then
      InsertTxt TmpTxtObj, Format(dblDis, "0.00"), tmpPt, 3, "TK" '边长
    End If
  Next i

  '读取20行以后的
  Dim intDivi As Integer
  intDivi = totalRow \ 20  '整除
  Dim intMod As Integer
  intMod = totalRow Mod 20 '取余
  Dim TotalPage As Integer
  If intMod = 0 Then
    TotalPage = intDivi
  Else
    TotalPage = intDivi + 1
  End If

  Dim m As Integer
  For m = 1 To TotalPage - 1
    Jzd_InsPt = pInsPt
    Jzd_InsPt(0) = Jzd_InsPt(0) + 6.612 + m * 200
    Jzd_InsPt(1) = Jzd_InsPt(1) + (m + 1) * 169.77

    For i = m * 20 To (m + 1) * 20
    tmpPt = Jzd_InsPt
    tmpPt(1) = Jzd_InsPt(1) - i * 8.485
   
      If i = totalRow Then Exit Sub  '到了文件末尾
     
      tmpPt = Jzd_InsPt
      tmpPt(1) = Jzd_InsPt(1) - i * 8.485
   
      strJZDInfo = ReadFileLine(strFile, i)
      varJZDInfo = Split(strJZDInfo, ",")
      With myJZD
        .DH = varJZDInfo(0)
        .x = varJZDInfo(1)
        .y = varJZDInfo(2)
      End With
   
      If i <> totalRow - 1 Then
        strJZDInfo = ReadFileLine(strFile, i + 1)
        varJZDInfo = Split(strJZDInfo, ",")
        With myJZD1
          .DH = varJZDInfo(0)
          .x = varJZDInfo(1)
          .y = varJZDInfo(2)
        End With
     
        dblDis = Distance(myJZD.x, myJZD1.x, myJZD.y, myJZD1.y)
      End If
   
      If i <> totalRow - 1 Then
        InsertTxt TmpTxtObj, Trim(str(i)), tmpPt, 3, "TK"  '序号
      Else
        InsertTxt TmpTxtObj, "1", tmpPt, 3, "TK"  '序号
      End If
   
      tmpPt = TmpTxtObj.InsertionPoint
      tmpPt(0) = tmpPt(0) + 19.603
      InsertTxt TmpTxtObj, Trim(myJZD.DH), tmpPt, 3, "TK" '点号
   
      tmpPt = TmpTxtObj.InsertionPoint
      tmpPt(0) = tmpPt(0) + 24.002
      InsertTxt TmpTxtObj, Trim(myJZD.x), tmpPt, 3, "TK" 'X坐标
   
      tmpPt = TmpTxtObj.InsertionPoint
      tmpPt(0) = tmpPt(0) + 37.976
      InsertTxt TmpTxtObj, Trim(myJZD.y), tmpPt, 3, "TK" 'Y坐标
   
      If i <> totalRow - 1 Then
        tmpPt = TmpTxtObj.InsertionPoint
        tmpPt(0) = tmpPt(0) + 40.417
        tmpPt(1) = tmpPt(1) - 4.296
        If i <> (m + 1) * 20 Then
          InsertTxt TmpTxtObj, Format(dblDis, "0.00"), tmpPt, 3, "TK" '边长
        End If
      End If
   
    Next i
  Next m
End Sub
'——————————————————————————————————————
'名称：InsertTxt
'作者：罗简单
'日期：2008-9-4
'功能：插入文本
'注意：pTxtObj必须为传参数
'——————————————————————————————————————
Public Sub InsertTxt(pTxtObj As AcadText, ByVal strTxt As String, ByVal pBasePt As Variant, ByVal Height As Double, ByVal strLyr As String)
  Set pTxtObj = ThisDrawing.ModelSpace.AddText(strTxt, pBasePt, Height)
  pTxtObj.Layer = strLyr
  pTxtObj.Alignment = acAlignmentBottomLeft
  pTxtObj.TextAlignmentPoint = pBasePt
  pTxtObj.ScaleFactor = 1  '宽度比例设为1

  pTxtObj.Update
End Sub
'——————————————————————————————————————
'名称：InsertJZDInfo
'作者：罗简单
'日期：2008-9-5
'功能：在界址点成果表中插入界址点的信息（点号、X坐标、Y坐标、边长）
'——————————————————————————————————————
Public Sub InsertJZDInfo(pTxtObj As AcadText, ByVal strTxt As String, ByVal pBasePt As Variant, ByVal Height As Double, ByVal strLyr As String)
  Set pTxtObj = ThisDrawing.ModelSpace.AddText(strTxt, pBasePt, Height)
  pTxtObj.Layer = strLyr
  pTxtObj.Alignment = acAlignmentBottomLeft
  pTxtObj.TextAlignmentPoint = pBasePt
  pTxtObj.ScaleFactor = 1  '宽度比例设为1

  pTxtObj.Update
End Sub

'——————————————————————————————————————
'名称：InsertJZDCGB
'作者：罗简单
'日期：2008-8-22
'功能：为程序添加界址点成果表
'——————————————————————————————————————
Public Sub InsertJZDCGB(pBasePt As Variant, ByVal strName As String)
  Dim strPath As String
  strPath = "D:\Program Files\CASS70\BLOCKS\" & strName & ".dwg"

  Dim pBlock As AcadBlockReference
  Set pBlock = ThisDrawing.ModelSpace.InsertBlock(pBasePt, strPath, 1, 1, 1, 0)
  pBlock.Update
End Sub
'—————————————————————————————————————
'名称：ReadFileLine
'作者：罗简单
'日期：2008-9-4
'功能：读取文本文件指定行的内容，以及总行数
'—————————————————————————————————————
Public Function ReadFileLine(fFile As String, numLine As Integer) As String
  Dim i As Integer
  Dim myFSO As New FileSystemObject, myFile As File, myTs As TextStream
  Set myFile = myFSO.GetFile(fFile)
  Set myTs = myFile.OpenAsTextStream(ForReading)
  i = 1
  Do While Not myTs.AtEndOfStream
    If i <> numLine Then
      myTs.ReadLine
    Else
      ReadFileLine = myTs.ReadLine
    End If
    i = i + 1
  Loop

  Set myTs = Nothing
End Function
'——————————————————————————————————————
'名称：ReadJzdInfo_To_Txt
'作者：罗简单
'日期：2008-9-5
'功能：将宗地从左上角开始，顺时针读取界址点信息到文本文件
'——————————————————————————————————————
Public Sub ReadJZDINFO_To_Txt(pLwpObj As AcadLWPolyline)
  Dim gType, gData
  pLwpObj.GetXData "SOUTH", gType, gData
  Dim strDJH As String
  strDJH = gData(2)
  Dim myPointlist As Variant
  myPointlist = Pt2wTo3w(pLwpObj)

  Dim pType, pData
  BuildFilter pType, pData, 0, "Circle", 8, "JZP"

  Dim sset As AcadSelectionSet
  Set sset = CreateSelectionSet2

  '建立选择集
  sset.Clear
  sset.SelectByPolygon acSelectionSetFence, myPointlist, pType, pData
  Dim strData As String
  Dim tmpData As String
  Dim numVer As Integer
  Dim i As Integer  '循环Index
  Dim pCirObj As AcadCircle
  Dim cenPt As Variant
  numVer = (UBound(pLwpObj.Coordinates) + 1) / 2 - 1
  Dim intWNVer As Integer  '左上角
  intWNVer = TheLeftTopVer(pLwpObj)
  If IsClockWise(pLwpObj) Then  '顺时针
    If intWNVer = 0 Then '第一个点
     
      '循环界址点
      For Each pCirObj In sset
        ReadJZDINFO pCirObj
      Next pCirObj
     
      '再读头
      Set pCirObj = sset.Item(0)
        ReadJZDINFO pCirObj
     
    ElseIf intWNVer = numVer Then '最后一个点
      '先读取最后一个点
      Set pCirObj = sset.Item(numVer)
      ReadJZDINFO pCirObj
     
      '在从头读到尾
      For Each pCirObj In sset
        ReadJZDINFO pCirObj
      Next pCirObj
   
    Else  '左上角不是首、尾点
      '从左上角读到尾部
      For i = intWNVer To numVer
        Set pCirObj = sset.Item(i)
        ReadJZDINFO pCirObj
      Next i
     
      '再从头读到左上角
      For i = 0 To intWNVer
        Set pCirObj = sset.Item(i)
        ReadJZDINFO pCirObj
      Next i
    End If
   
  Else  '逆时针
    If intWNVer = 0 Then  '如果坐上角为第一个点
      '先读取第一个点
       Set pCirObj = sset.Item(0)
       ReadJZDINFO pCirObj
     
      '再从尾读到头
      For i = numVer To 0 Step -1
        Set pCirObj = sset.Item(i)
        ReadJZDINFO pCirObj
      Next i
    ElseIf intWNVer = numVer Then '如果左上角为最后一个点
      '先从尾读到头
      For i = numVer To 0 Step -1
        Set pCirObj = sset.Item(i)
        ReadJZDINFO pCirObj
      Next i
     
      '再读尾
      Set pCirObj = sset.Item(numVer)
      ReadJZDINFO pCirObj
    Else  '如果左上角既不为第一个点也不为最后一个点
      '先从左上角读到头
      For i = intWNVer To 0 Step -1
        Set pCirObj = sset.Item(i)
        ReadJZDINFO pCirObj
      Next i
     
      '再从尾读到左上角
      For i = numVer To intWNVer Step -1
        Set pCirObj = sset.Item(i)
        ReadJZDINFO pCirObj
      Next i
    End If
  End If

End Sub
Public Sub ReadJZDINFO(pCirObj As AcadCircle)
  Dim cenPt As Variant
  Dim strData As String
  Dim gType, gData
  cenPt = pCirObj.Center
  '获取界址点号
  pCirObj.GetXData "SOUTH", gType, gData
  strData = ""
  strData = Trim(str(gData(3))) & "," & Format(cenPt(1), "0.000") & "," & Format(cenPt(0), "0.000")

  Open "C:\JZDCGB.txt" For Append As #1
    Print #1, strData
  Close #1
End Sub
Sub testReadJzdin()
  Dim p As AcadEntity
  Dim pp As Variant
  ThisDrawing.Utility.GetEntity p, pp

  ReadJZDINFO_To_Txt p
End Sub
'————————————————————————————————————
'名称：TheLeftTopVer
'作者：罗简单
'日期：2008-9-4
'功能：查找多段线最左上角节点的坐标
'原理：先得到最小矩形，然后判断每一个节点到最小矩形的下边和右边距离和
'      和最大的就是最左上角的点
'————————————————————————————————————
Public Function TheLeftTopVer(ByVal pLwpObj As AcadLWPolyline) As Integer

  Dim extMin, extMax
  pLwpObj.GetBoundingBox extMin, extMax
  Dim numVer As Integer
  numVer = (UBound(pLwpObj.Coordinates) + 1) / 2
  '先取第一个节点到最小矩形的距离
  Dim tmpVer As Variant
  tmpVer = pLwpObj.Coordinate(0)
  Dim pDis As Double
  Dim pTmp_Dis As Double
  Dim No_LeftTop As Integer
  pDis = Abs((tmpVer(0) - extMax(0))) + Abs((tmpVer(1) - extMin(1)))
  No_LeftTop = 0

  Dim i As Integer
  '循环每一个节点
  For i = 1 To numVer - 1
    tmpVer = pLwpObj.Coordinate(i)
    pTmp_Dis = Abs((tmpVer(0) - extMax(0))) + Abs((tmpVer(1) - extMin(1)))
    If pTmp_Dis > pDis Then
      pDis = pTmp_Dis
      No_LeftTop = i
    End If
  Next i

  TheLeftTopVer = No_LeftTop
End Function
'——————————————————————————————————————
'名称：IsClockWise
'作者：罗简单
'日期：2008-9-4
'功能：判断一个多段线节点的方向是否为顺时针。
'——————————————————————————————————————
Public Function IsClockWise(ByVal pLwpObj As AcadLWPolyline) As Boolean
  IsClockWise = False '初始化，多段线节点旋转方向为逆时针

  Dim pLwpObj_Offset As AcadLWPolyline
  Dim varOffset As Variant
  varOffset = pLwpObj.Offset(2)

  Set pLwpObj_Offset = varOffset(0)

  Dim Area As Double, Area_Offset As Double
  Area = pLwpObj.Area: Area_Offset = pLwpObj_Offset.Area
  If Area_Offset < Area Then
    IsClockWise = True
  Else
    IsClockWise = False
  End If

  pLwpObj_Offset.Delete
End Function

'****************************************************************
'名称：Pt2wTo3w
'作者：罗简单
'日期：2008-7-5
'功能：将多段线的二维坐标转三维坐标的函数，三维坐标中Z值为0
'目的：在使用selectbypolygon方法时，要求的坐标组必须是三维的。
'****************************************************************
Public Function Pt2wTo3w(ByVal Lwp As AcadLWPolyline) As Variant
'Lwp坐标集
Dim CoorLwp As Variant
    CoorLwp = Lwp.Coordinates
'坐标个数，二维坐标
Dim k As Integer
    k = UBound(CoorLwp) + 1
'把二维坐标转为三维坐标，但Z值为0
Dim c As Integer
    c = k * 3 / 2 - 1
Dim points() As Double '定义动态坐标点
ReDim points(0 To c) As Double
     
'二维坐标转换成三位坐标
'例如：(12.34,35.67)转换成(12.34,35.67,0)
Dim g As Integer, v As Integer
For g = 0 To k - 1
    v = g \ 2
    points(g + v) = CoorLwp(g)
Next g
    Pt2wTo3w = points
End Function

'创建过滤器的函数
Public Sub BuildFilter(TypeArray, DataArray, ParamArray gCodes())
    Dim fType() As Integer, fData()
    Dim index As Long, i As Long
   
    index = LBound(gCodes) - 1
    For i = LBound(gCodes) To UBound(gCodes) Step 2
        index = index + 1
        ReDim Preserve fType(0 To index)
        ReDim Preserve fData(0 To index)
        fType(index) = CInt(gCodes(i))
        fData(index) = gCodes(i + 1)
    Next
    TypeArray = fType: DataArray = fData
End Sub
'创建空间选择集的函数
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
    Dim ss As AcadSelectionSet
    On Error Resume Next
    Set ss = ThisDrawing.SelectionSets(ssName)
    If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    ss.Clear
    Set CreateSelectionSet = ss
End Function
'创建空间选择集的函数2
Public Function CreateSelectionSet2(Optional ssName As String = "ss2") As AcadSelectionSet
    Dim ss2 As AcadSelectionSet
    On Error Resume Next
    Set ss2 = ThisDrawing.SelectionSets(ssName)
    If Err Then Set ss2 = ThisDrawing.SelectionSets.Add(ssName)
    ss2.Clear
    Set CreateSelectionSet2 = ss2
End Function
'创建距离函数
Public Function Distance(x0 As Variant, x1 As Variant, y0 As Variant, y1 As Variant) As Double
   Dim d As Double
   d = Sqr((x0 - x1) ^ 2 + (y0 - y1) ^ 2)
   Distance = d
End Functio


请教高人指点！先谢了！

mikewolf2k

加载后，按ALT+F8, 然后可以看到InsertJZDCGB_Batch_Run，执行。

tianyuan

请问，如何加载？

tianyuan

该程序如何在lsp中加载？

woaishuijia

打开VBA编辑器,鼠标双击"工程资源管理器"中的"thisdrawing"对象,在其代码窗口中粘贴一楼的代码,保存.(下面以该文件路径和文件名为"D:\我的文档\CADVBA\12345.dvb"为例)
打开 WINDOWS 记事本程序,写入下列代码

2. (defun c:XXX ()
   
3.   (vl-vbarun "D:\\我的文档\\CADVBA\\12345.dvb!Thisdrawing.InsertJZDCGB_Batch_Run" )
   
4.   (princ)
   
5. )

(defun c:XXX ()<br />   (vl-vbarun "D:\\我的文档\\CADVBA\\12345.dvb!Thisdrawing.InsertJZDCGB_Batch_Run" )<br />   (princ)<br /> )

其中第一行中的"XXX"是你自己定义的CAD命令名,可以是"abc",xy"之类,不要与现有的CAD命令相同,便于自己记忆和使用为好.
第二行的文件路径中,要注意"\"是成对使用的,两个当成一个用,这是LISP语法.在路径和文件名的后面是一个感叹号"!",再后面和模块名称,"."和宏名称.
保存该文本文件,注意文件扩展名必须是"lsp",如"abc.lsp",大家通常的习惯是文件名与代码中的自定义命令名相同,便于区别和记忆.
使用时,先在CAD中用"appload"命令加载这个lsp文件.然后每次运行该VBA程序时,只要在命令行键入你的自定义命令就自动加载并运行了.

markc0826

利用 vbaload 指令来载入您的*.dvb档
利用 vbarun 指令来执行你要的宏..

allan_ham

我的程序是窗口形式的，在Thisdrawing里没有任何代码，运行时是扑捉用户鼠标操作的。该如何实现一键运行？