以左上角为起点，顺时针为方向生成界址点成果表。如图：
代码如下：
程序太长，分两次发：
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"
加载中…
(2008-09-18 17:54:13)