请教一下，这个vba程序如何加载到cad中并运行，命令是什么？（初学）
Type JZDINFODH 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
请教高人指点！先谢了！
加载后，按ALT+F8, 然后可以看到InsertJZDCGB_Batch_Run，执行。
请问，如何加载？
该程序如何在lsp中加载？ 打开VBA编辑器,鼠标双击"工程资源管理器"中的"thisdrawing"对象,在其代码窗口中粘贴一楼的代码,保存.(下面以该文件路径和文件名为"D:\我的文档\CADVBA\12345.dvb"为例)
打开 WINDOWS 记事本程序,写入下列代码(defun c:XXX ()
(vl-vbarun "D:\\我的文档\\CADVBA\\12345.dvb!Thisdrawing.InsertJZDCGB_Batch_Run" )
(princ)
)其中第一行中的"XXX"是你自己定义的CAD命令名,可以是"abc",xy"之类,不要与现有的CAD命令相同,便于自己记忆和使用为好.
第二行的文件路径中,要注意"\"是成对使用的,两个当成一个用,这是LISP语法.在路径和文件名的后面是一个感叹号"!",再后面和模块名称,"."和宏名称.
保存该文本文件,注意文件扩展名必须是"lsp",如"abc.lsp",大家通常的习惯是文件名与代码中的自定义命令名相同,便于区别和记忆.
使用时,先在CAD中用"appload"命令加载这个lsp文件.然后每次运行该VBA程序时,只要在命令行键入你的自定义命令就自动加载并运行了. 利用 vbaload 指令来载入您的*.dvb档
利用 vbarun 指令来执行你要的宏.. 我的程序是窗口形式的，在Thisdrawing里没有任何代码，运行时是扑捉用户鼠标操作的。该如何实现一键运行？
页:
[1]