沙漠骆驼工具箱源码-19地形图切剖面
工具条：地形图切剖面（根据等高线标高）1 界面
2代码如下
Private Type dingdianzuobbiao '自定义多段线顶点坐标
xy As Variant
distance As Double
End Type
Private Type jiaodianzuobiao '定义交点xy坐标，含有高程，距离
xy As Variant
z As Double
distance As Double
End Type
Dim pqxdingdian() As dingdianzuobbiao'定义剖切线顶点坐标
Dim jiaodian() As jiaodianzuobiao'定义交点坐标，有高程信息
Dim jiaodianzongshu As Double '定义交点坐标个数
Dim juligaocheng() As Double
Dim zigao As Single '字体高度
Dim xscale As Double '定义x方向比例
Dim yscale As Double '设置垂直比例
Dim maxgc As Double '设置最大高程
Dim mingc As Double '设置最小高程
Dim pqxlength As Double '定义剖切线长度
'Dim pqxstartpoint(0 To 2)As Double '定义剖切线起始点坐标
'Dim pqxendpoint(0 To 2) As Double '定义剖切线终点坐标
'Dim pqxstartpoint As Variant
'Dim pqxendpoint As Variant
Dim pqxqidian As Variant '定义剖切线的起点位置
Dim dy As Integer '设置高程间隔距离，单位为m
Dim dx As Double '设置水平间隔距离，单位为m
Dim ndy As Integer '设置标尺干最下面多出的距离为 n*dy
Dim currentlayername As String
Dim currentcolor As String
Dim currenttextstyle As String
Dim currentlineweight As String
Dim currentosmode As Integer
Dim pqxpline As AcadLWPolyline'定义剖切线
Dim dmxpline As AcadLWPolyline'定义地面线
Dim dgxlayername As String '确定选择的等高线图层名称
Dim biaochiganlayer As AcadLayer '定义标尺杆图层
Dim shujulanlayerAs AcadLayer '定义数据栏图层
Dim dimianxianlayerAs AcadLayer '定义地面线图层
Dim biaotilayer As AcadLayer '定义标题文字图层
Dim pptlive As AcadLWPolyline'定义交点显示符号，两个多段线圆圈，并显示宽度
Dim pouqiefangxiang As Boolean'定义剖切方向，为布尔型变量
Private Sub ComboBox1_Click()
dgxlayername = ComboBox1.Text
End Sub
Private Sub CommandButton1_Click()'1 确定等高线图层之后，选择剖切线
Me.Hide
On Error Resume Next
quxiao '调用取消命令
If dgxlayername = "" Then
ThisDrawing.Utility.prompt "-----等高线图层获取错误，请重新获取等高线图层------" & vbCrLf
Exit Sub
End If
'选择剖切线
'删除显示的点
pptlive.Delete
If Error.Err Then Err.Clear
Dim base As Variant
ThisDrawing.Utility.GetEntity pqxpline, base, "请点选剖切线，必须为多段线:" & vbCrLf
If Err.Number <> 0 Then
ThisDrawing.Utility.prompt "-----剖切线选取失败------" & vbCrLf
Me.show
Err.Clear
Exit Sub
End If
pqxpline.Elevation = 0 '将剖切线标高归零，以便后面使用
ThisDrawing.Utility.prompt "-----剖切线选取成功------" & vbCrLf
currentosmode = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 1
pqxpline.Highlight True
pqxqidian = ThisDrawing.Utility.GetPoint(, "请选取剖切的起点位置：")
pqxpline.Highlight False
ThisDrawing.SetVariable "OSMODE", currentosmode
getjiaodian pqxpline, pqxqidian
'如果以上选择都正确的话，将显示窗体
Me.height = 274 '改变窗体大小,274,121
Me.width = 225
ListBox1.Clear
Label15.Visible = True
Label16.Visible = False
Me.show
End Sub
'2 然后插入剖面图，包括标尺杆，数据栏，地面线
Private Sub CommandButton2_Click()
On Error Resume Next '删除交点显示符号，两个多段线圆圈
quxiao '调用取消命令
pptlive.Delete
If Error.Err Then Err.Clear
Me.Hide
zigao = ComboBox4.Text
yscale = ComboBox2.Text
xscale = ComboBox3.Text
dy = Left(ComboBox5.Text, 2)
dx = ComboBox6.Text
ndy = ComboBox7.Text
On Error Resume Next
currentlayername = ThisDrawing.ActiveLayer.name
currentcolor = ThisDrawing.GetVariable("cecolor")
currenttextstyle = ThisDrawing.GetVariable("textstyle")
currentlineweight = ThisDrawing.Preferences.Lineweight
Set currentlinetype = ThisDrawing.ActiveLinetype
ThisDrawing.ActiveLinetype = ThisDrawing.Linetypes.Item(1) '设置线形为bylayer
ThisDrawing.SetVariable "cecolor", "256"
ThisDrawing.SetVariable "textstyle", "wh_lkx"
ThisDrawing.Preferences.Lineweight = acLnWtByLayer '设置默认线宽
Dim base As Variant
base = ThisDrawing.Utility.GetPoint(, "请选取插入点：")
huabiaochigan base, mingc, maxgc, yscale, zigao, dy '插入左标尺杆
If CheckBox2.value Then '插入右标尺杆
Dim base2(0 To 2) As Double
base2(0) = base(0) + 1.5 + pqxlength * 1000 / xscale '+10
base2(1) = base(1)
youhuabiaochigan base2, mingc, maxgc, yscale, zigao, dy
End If
'base(0) = base(0) + 10 '向右平移10个单位
huadimianxian base, xscale, yscale, mingc, juligaocheng'先画地面线，数据栏里的数据根据地面线生成
'base(0) = base(0) - 10
shujulan base, pqxlength, zigao, xscale, mingc ' 插入数据栏外框,+ 10 * xscale / 1000
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(currentlayername) '恢复图层
ThisDrawing.SetVariable "cecolor", currentcolor '恢复绘图颜色
ThisDrawing.SetVariable "textstyle", currenttextstyle
ThisDrawing.ActiveLinetype = currentlinetype '恢复线型
ThisDrawing.Preferences.Lineweight = currentlineweight
Me.show
End Sub
Private Sub CommandButton3_Click()
Me.Hide
End Sub
'包含有如下几个方面:
'用剖切线栏选对象以创建选择集,选择等高线层
'返回剖切线与选择集的交点坐标,还包含距离和高程
'返回最大高程，最小高程
Private Sub getjiaodian(plineobj As AcadLWPolyline, qidian As Variant) '参数为剖切线和剖切方向的起始点
On Error Resume Next
Dim i As Integer
ReDim pqxdingdian(UBound(plineobj.Coordinates) \ 2) '重新定义剖切线顶点坐标,并存储多段线定点坐标
For i = 0 To UBound(plineobj.Coordinates) \ 2
pqxdingdian(i).xy = plineobj.Coordinate(i)
pqxdingdian(i).distance = plinedistancep1(pqxdingdian(i).xy, plineobj)
'MsgBox pqxdingdian(i).distance
Next
pqxlength = plineobj.length'剖切线长度
plineobj.Elevation = 0 '将剖切线标高归零
Dim sset As AcadSelectionSet '创建等高线选择集
Dim count As Integer
count = (UBound(plineobj.Coordinates) \ 2 + 1) * 3 - 1
ReDim plinelist(count) As Double'剖切线坐标列表，为三元数组,x,y,z 用于栏选等高线
For i = 0 To UBound(plineobj.Coordinates) \ 2
plinelist(i * 3) = plineobj.Coordinates(i * 2) '给x坐标赋值
plinelist(i * 3 + 1) = plineobj.Coordinates(i * 2 + 1) '给y坐标赋值
plinelist(i * 3 + 2) = 0'给z坐标赋0值
Next
Dim filtertype(4) As Integer '定义选择过滤器类型的dsf组码
Dim filterdata(4) As Variant '定义选择过滤器的值
filtertype(0) = -4
filterdata(0) = "<or"
filtertype(1) = 0
filterdata(1) = "lwpolyline"
filtertype(2) = 0
filterdata(2) = "polyline"
filtertype(3) = -4
filterdata(3) = "or>"
filtertype(4) = 8
filterdata(4) = dgxlayername
'再加一个图层过滤器 屏幕放大了再选，要不然选不完
Dim boundary1 As Variant
Dim boundary2 As Variant
plineobj.GetBoundingBox boundary1, boundary2
ThisDrawing.Application.ZoomWindow boundary1, boundary2
Set sset = ThisDrawing.SelectionSets.Add("ss1")
If Err.Number <> 0 Then
Err.Clear
Set sset = ThisDrawing.SelectionSets.Item("ss1")
sset.Clear
End If
sset.SelectByPolygon acSelectionSetFence, plinelist, filtertype, filterdata '栏选对象
ThisDrawing.Application.ZoomPrevious '返回上一个屏幕
If sset.count = 0 Then
dgxlayername = "" '如果没切到等高线，将dgxlayername 设为空值
sset.Clear
sset.Delete '删除选择集
Exit Sub '并且退出
End If
'测试选择集中对象的顺序,用不同的颜色显示
' For i = 0 To sset.count - 1
' Dim ceshipt(0 To 2) As Double
' Dim aaAs AcadLWPolyline
' Set aa = sset.Item(i)
' ceshipt(0) = aa.Coordinates(0)
' ceshipt(1) = aa.Coordinates(1)
' ThisDrawing.ModelSpace.AddText i, ceshipt, 8
' Next
Dim pqx As AcadLWPolyline '下面排除剖切线，剖切线也在选择集里
Dim removeobjects(0) As AcadObject'移出对象数组，
For i = 0 To sset.count - 1
Set pqx = sset.Item(i)
If pqx.Coordinates(0) = plineobj.Coordinates(0) And _
pqx.Coordinates(1) = plineobj.Coordinates(1) And _
pqx.Coordinates(2) = plineobj.Coordinates(2) And _
pqx.Coordinates(3) = plineobj.Coordinates(3) Then
Set removeobjects(0) = pqx
sset.RemoveItems removeobjects '把剖切线从选择集中移出
'pqx.color = acRed
Exit For
End If
Next
Dim jiaodiangeshu As Double '定义jiaodiangeshu 为过程变量，
Dim maxjiaodiangeshu As Double
maxjiaodiangeshu = 500 '500 假设剖切线与同一条等高线最多有500个交点，一般不会这么多
ReDim maxjiaodian(maxjiaodiangeshu) As jiaodianzuobiao'定义局部变量数组
mingc = sset.Item(0).Elevation '初始最小高程
maxgc = sset.Item(0).Elevation '初始最大高程
'MsgBox mingc & "," & maxgc
maxjiaodian(0).z = sset.Item(0).Elevation
maxjiaodian(0).xy = pqxdingdian(0).xy
maxjiaodian(0).distance = 0
i = 0
Dim j As Double
Dim ii As Double
Dim kuandui As Double
ReDim kuandu(sset.count - 1) As Double '定义多段线宽度
' For kuandui = 0 To sset.count - 1 '设置等高线宽度为0，以便于求交点
' kuandu(kuandui) = sset.Item(kuandui).ConstantWidth
' sset.Item(kuandui).ConstantWidth = 0
' Next
Dim pp As Variant '用于存放大于一个交点的情况
Dim countpp As Double'用于存放pp的上限值
Dim minlinghangxianshi As Long'用于命令行显示进度个数
minlinghangxianshi = 1
Dim kaishishijian As Variant
Dim jieshushijian As Variant
'计时开始
kaishishijian = ThisDrawing.GetVariable("cdate")
'MsgBox ThisDrawing.GetVariable("tdusrtimer")
For ii = 1 To sset.count
i = i + 1
maxjiaodian(i).z = sset.Item(ii - 1).Elevation'存储等高线高程
'MsgBox maxjiaodian(i).z
If maxjiaodian(i).z > maxgc Then maxgc = maxjiaodian(i).z '获取最大高程
If maxjiaodian(i).z < mingc Then mingc = maxjiaodian(i).z '获取最小高程
sset.Item(ii - 1).Elevation = 0 '将等高线标高归零
'kuandu = sset.Item(ii - 1).ConstantWidth '存储等高线宽度
'If kuandu <> 0 Then sset.Item(ii - 1).ConstantWidth = 0 '将等高线宽度设为0
'sset.Item(ii - 1).ConstantWidth = 0
pp = sset.Item(ii - 1).IntersectWith(plineobj, acExtendNone) '求交点
sset.Item(ii - 1).Elevation = maxjiaodian(i).z'恢复等高线标高数值
'If kuandu <> 0 Then sset.Item(ii - 1).ConstantWidth = kuandu'恢复等高线宽度
'sset.Item(ii - 1).ConstantWidth = kuandu
countpp = (UBound(pp) + 1) \ 3 '同一条等高线的交点个数
If countpp > 1 Then '同一条等高线的交点个数大于1时
Dim cc(0 To 2) As Double '用来传递坐标值
For j = 0 To countpp - 1
cc(0) = pp(3 * j)
cc(1) = pp(3 * j + 1)
cc(2) = 0
maxjiaodian(i + j).xy = cc
maxjiaodian(i + j).z = maxjiaodian(i).z
'ThisDrawing.ModelSpace.AddText maxjiaodian(i + j).z, maxjiaodian(i + j).xy, 20
ThisDrawing.Utility.prompt "正在处理第 " & minlinghangxianshi & " 个交点" & vbCrLf
minlinghangxianshi = minlinghangxianshi + 1
Next
i = i + j - 1
Else '同一条等高线的交点个数等于1时
maxjiaodian(i).xy = pp
End If
'命令行显示正在处理的交点
ThisDrawing.Utility.prompt "正在处理第 " & minlinghangxianshi & " 个交点" & vbCrLf
minlinghangxianshi = minlinghangxianshi + 1
Next
' For kuandui = 0 To sset.count - 1
' sset.Item(kuandui).ConstantWidth = kuandu(kuandui)
' Next
'MsgBox ThisDrawing.GetVariable("tdusrtimer")
'计时结束
jieshushijian = ThisDrawing.GetVariable("cdate")
'MsgBox str((jieshushijian - kaishishijian) * 1000000)
ThisDrawing.Utility.prompt "一共处理了 " & minlinghangxianshi - 1 & " 个交点。 @@@共耗时 " _
& Format((jieshushijian - kaishishijian) * 1000000, "0.000000") & " 秒@@@" & vbCrLf
jiaodiangeshu = i + 1 '确定实际存在的交点个数
ReDim jiaodian(jiaodiangeshu) '重新定义交点坐标数组
For i = 0 To jiaodiangeshu - 1
jiaodian(i).xy = maxjiaodian(i).xy
jiaodian(i).z = maxjiaodian(i).z
jiaodian(i).distance = plinedistancep1(jiaodian(i).xy, plineobj) '调用函数，计算交点距多段线起点的距离
'ThisDrawing.ModelSpace.AddText i, jiaodian(i).xy, 3
'ThisDrawing.ModelSpace.AddText jiaodian(i).z, jiaodian(i).xy, 3
Next
' With jiaodian(jiaodiangeshu) '加入剖切线末点
' '.z = sset.Item(sset.count - 1).Elevation '.z = jiaodian(jiaodiangeshu - 1).z
' .xy = plineobj.Coordinate(UBound(plineobj.Coordinates) \ 2)'二元数组
' .distance = plinedistancep1(.xy, plineobj)
' End With
'到此完成了剖切线与等高线所有交点的坐标，并添加了剖切线的两个端点坐标
'根据各交点坐标到起始点的距离distance进行排序
Dim ttt As jiaodianzuobiao
For i = 0 To jiaodiangeshu - 2
For j = i + 1 To jiaodiangeshu - 1
If jiaodian(i).distance > jiaodian(j).distance Then
ttt = jiaodian(i)
jiaodian(i) = jiaodian(j)
jiaodian(j) = ttt
End If
Next
Next
jiaodian(jiaodiangeshu).xy = plineobj.Coordinate(UBound(plineobj.Coordinates) \ 2) '二元数组
jiaodian(jiaodiangeshu).distance = plineobj.length
jiaodian(jiaodiangeshu).z = jiaodian(jiaodiangeshu - 1).z
'下面确定剖切方向
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double
ReDim juligaocheng(jiaodiangeshu * 2 + 1) As Double'用于存放画剖面线的二元数组，距离，高程
If Abs(qidian(0) - pqxdingdian(0).xy(0)) / pqxlength < 0.0001 And _
Abs(qidian(1) - pqxdingdian(0).xy(1)) / pqxlength < 0.0001 Then'qiandian 是参数变量
pt1(0) = pqxdingdian(0).xy(0)
pt1(1) = pqxdingdian(0).xy(1)
pt2(0) = pqxdingdian(UBound(plineobj.Coordinates) \ 2).xy(0)
pt2(1) = pqxdingdian(UBound(plineobj.Coordinates) \ 2).xy(1)
For i = 0 To jiaodiangeshu '方向和多段线方向相同
juligaocheng(2 * i) = jiaodian(i).distance
juligaocheng(2 * i + 1) = jiaodian(i).z
'ThisDrawing.ModelSpace.AddText juligaocheng(2 * i), jiaodian(i).xy, 0.5
Next
pouqiefangxiang = True
Else '剖切线方向和多段线方向相反 UBound(plineobj.Coordinates) \ 2
' pt1(0) = jiaodian(jiaodiangeshu).xy(0): pt1(1) = jiaodian(jiaodiangeshu).xy(1)
' pt2(0) = jiaodian(0).xy(0): pt2(1) = jiaodian(0).xy(1)
pouqiefangxiang = False
pt1(0) = pqxdingdian(UBound(plineobj.Coordinates) \ 2).xy(0)
pt1(1) = pqxdingdian(UBound(plineobj.Coordinates) \ 2).xy(1)
pt2(0) = pqxdingdian(0).xy(0)
pt2(1) = pqxdingdian(0).xy(1)
Dim ppt As Integer
ppt = UBound(plineobj.Coordinates) \ 2
Dim addpline As AcadLWPolyline '新增加一个多段线，并且方向相反
ReDim addplinelist(UBound(plineobj.Coordinates)) As Double
For i = 0 To ppt
pqxdingdian(i).xy = plineobj.Coordinate(ppt - i)
addplinelist(2 * i) = pqxdingdian(i).xy(0)
addplinelist(2 * i + 1) = pqxdingdian(i).xy(1)
Next
Set addpline = ThisDrawing.ModelSpace.AddLightWeightPolyline(addplinelist)
For i = 0 To ppt
pqxdingdian(i).distance = plinedistancep1(pqxdingdian(i).xy, addpline)
'MsgBox pqxdingdian(i).distance
Next
For i = 0 To jiaodiangeshu '方向和多段线方向相反
juligaocheng(2 * i) = plinedistancep1(jiaodian(jiaodiangeshu - i).xy, addpline)
juligaocheng(2 * i + 1) = jiaodian(jiaodiangeshu - i).z
'ThisDrawing.ModelSpace.AddText juligaocheng(2 * i), jiaodian(jiaodiangeshu - i).xy, 0.5
Next
addpline.Delete
End If
ThisDrawing.ModelSpace.AddText "1", pt1, 5 '添加剖切线起点方向，方向为1->2
ThisDrawing.ModelSpace.AddText "2", pt2, 5
TextBox1.Text = maxgc
TextBox2.Text = mingc
jiaodianzongshu = jiaodiangeshu - 1 '存储剖切线和等高线的交点个数，不包括两个端点
sset.Delete
End Sub
'1画左标尺杆
Private Sub huabiaochigan(point As Variant, mingc As Double, maxgc As Double, yscale As Double, zigao As Single, dy As Integer)
'根据最大和最小高程的差值范围来自动确定间隔距离
Set biaochiganlayer = ThisDrawing.Layers.Add("标尺杆")
ThisDrawing.ActiveLayer = biaochiganlayer
biaochiganlayer.color = acGreen
Dim max As Double
Dim min As Double
'If maxgc = Int(maxgc) Then max = Int(maxgc) Else max = Int(maxgc) + 1
max = Int(maxgc) + dy
min = Int(mingc) - dy * ndy
Dim h As Double
h = max - min
If dy = 2 Then If h Mod 2 <> 0 Then h = h + 1
If dy = 5 Then If h Mod 5 <> 0 Then h = h - h Mod 5 + 5
If dy = 10 Then If h Mod 10 <> 0 Then h = h - h Mod 10 + 10
If dy = 20 Then If h Mod 20 <> 0 Then h = h - h Mod 20 + 20
If dy = 25 Then If h Mod 25 <> 0 Then h = h - h Mod 25 + 25
If dy = 40 Then If h Mod 40 <> 0 Then h = h - h Mod 40 + 40
If dy = 50 Then If h Mod 50 <> 0 Then h = h - h Mod 50 + 50
Dim pline1 As AcadLWPolyline
Dim p1(0 To 9) As Double
p1(0) = point(0): p1(1) = point(1)
p1(2) = p1(0): p1(3) = p1(1) + h * 1000 / yscale
p1(4) = p1(0) - 1.5: p1(5) = p1(3)
p1(6) = p1(0) - 1.5: p1(7) = p1(1)
p1(8) = p1(0): p1(9) = p1(1)
Set pline1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(p1)
Dim i As Double
Dim pt(0 To 3) As Double '多段线起点终点坐标
Dim pline2 As AcadLWPolyline '多段线填充，宽度为1.5
Dim textobj As AcadText
Dim textpoint(0 To 2) As Double'高程文字插入点
textpoint(0) = p1(0) - 2.75: textpoint(1) = p1(1)'最下边的高程
Set textobj = ThisDrawing.ModelSpace.AddText(min, textpoint, zigao)
With textobj
.Alignment = acAlignmentRight
.TextAlignmentPoint = textpoint
End With
For i = 1 To h \ dy \ 2
pt(0) = p1(0) - 0.75: pt(1) = p1(1) + (2 * i - 1) * dy * 1000 / yscale '多段线起点坐标
pt(2) = pt(0): pt(3) = p1(1) + 2 * i * dy * 1000 / yscale
Set pline2 = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
pline2.SetWidth 0, 1.5, 1.5
textpoint(0) = pt(0) - 2: textpoint(1) = pt(1)
Set textobj = ThisDrawing.ModelSpace.AddText(min + (2 * i - 1) * dy, textpoint, zigao)
With textobj
.Alignment = acAlignmentMiddleRight
.TextAlignmentPoint = textpoint
End With
If i = h / dy / 2 Then Exit For '取消标尺杆最上边的高程数据
textpoint(0) = pt(2) - 2: textpoint(1) = pt(3)
Set textobj = ThisDrawing.ModelSpace.AddText(min + 2 * i * dy, textpoint, zigao)
With textobj
.Alignment = acAlignmentMiddleRight
.TextAlignmentPoint = textpoint
End With
Next
textpoint(0) = p1(0) - 2.75: textpoint(1) = p1(3)'最上边的高程文字：高程(m)
Set textobj = ThisDrawing.ModelSpace.AddText("高程(m)", textpoint, zigao)
With textobj
.Alignment = acAlignmentTopRight
.TextAlignmentPoint = textpoint
End With
End Sub
'1画右标尺杆
Private Sub youhuabiaochigan(point As Variant, mingc As Double, maxgc As Double, yscale As Double, zigao As Single, dy As Integer)
'根据最大和最小高程的差值范围来自动确定间隔距离
Set biaochiganlayer = ThisDrawing.Layers.Add("标尺杆")
ThisDrawing.ActiveLayer = biaochiganlayer
biaochiganlayer.color = acGreen
Dim max As Double
Dim min As Double
'If maxgc = Int(maxgc) Then max = Int(maxgc) + dy Else max = Int(maxgc) + 1
max = Int(maxgc) + dy
min = Int(mingc) - dy * ndy
Dim h As Double
h = max - min
If dy = 2 Then If h Mod 2 <> 0 Then h = h + 1
If dy = 5 Then If h Mod 5 <> 0 Then h = h - h Mod 5 + 5
If dy = 10 Then If h Mod 10 <> 0 Then h = h - h Mod 10 + 10
If dy = 20 Then If h Mod 20 <> 0 Then h = h - h Mod 20 + 20
If dy = 25 Then If h Mod 25 <> 0 Then h = h - h Mod 25 + 25
If dy = 40 Then If h Mod 40 <> 0 Then h = h - h Mod 40 + 40
If dy = 50 Then If h Mod 50 <> 0 Then h = h - h Mod 50 + 50
Dim pline1 As AcadLWPolyline
Dim p1(0 To 9) As Double
p1(0) = point(0): p1(1) = point(1)
p1(2) = p1(0): p1(3) = p1(1) + h * 1000 / yscale
p1(4) = p1(0) - 1.5: p1(5) = p1(3)
p1(6) = p1(0) - 1.5: p1(7) = p1(1)
p1(8) = p1(0): p1(9) = p1(1)
Set pline1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(p1)
Dim i As Double
Dim pt(0 To 3) As Double '多段线起点终点坐标
Dim pline2 As AcadLWPolyline '多段线填充，宽度为1.5
Dim textobj As AcadText
Dim textpoint(0 To 2) As Double'高程文字插入点
textpoint(0) = p1(0) + 1.25: textpoint(1) = p1(1) '最下边的高程
Set textobj = ThisDrawing.ModelSpace.AddText(min, textpoint, zigao)
For i = 1 To h \ dy \ 2
pt(0) = p1(0) - 0.75: pt(1) = p1(1) + (2 * i - 1) * dy * 1000 / yscale '多段线起点坐标
pt(2) = pt(0): pt(3) = p1(1) + 2 * i * dy * 1000 / yscale
Set pline2 = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
pline2.SetWidth 0, 1.5, 1.5
textpoint(0) = pt(0) + 2: textpoint(1) = pt(1)
Set textobj = ThisDrawing.ModelSpace.AddText(min + (2 * i - 1) * dy, textpoint, zigao)
With textobj
.Alignment = acAlignmentMiddleLeft
.TextAlignmentPoint = textpoint
End With
If i = h / dy / 2 Then Exit For '取消标尺杆最上边的高程数据
textpoint(0) = pt(2) + 2: textpoint(1) = pt(3)
Set textobj = ThisDrawing.ModelSpace.AddText(min + 2 * i * dy, textpoint, zigao)
With textobj
.Alignment = acAlignmentMiddleLeft
.TextAlignmentPoint = textpoint
End With
Next
textpoint(0) = p1(0) + 1.5: textpoint(1) = p1(3) '最上边的高程文字：高程(m)
Set textobj = ThisDrawing.ModelSpace.AddText("高程(m)", textpoint, zigao)
With textobj
.Alignment = acAlignmentTopLeft
.TextAlignmentPoint = textpoint
End With
End Sub
'2画地面线
Private Sub huadimianxian(point As Variant, xscale As Double, yscale As Double, mingc As Double, juligaocheng() As Double)
Set dimianxianlayer = ThisDrawing.Layers.Add("地面线")
ThisDrawing.ActiveLayer = dimianxianlayer
Dim min As Double
min = Int(mingc) - dy * ndy
Dim count As Integer
'newuserucs point '新建坐标系，好像没用,那就不用了
count = UBound(juligaocheng)
ReDim bakjuligaocheng(count) As Double'新建一个数组，原数组不动，因为数组是按地址(byref)传递的,
Dim movevalue As Double
movevalue = juligaocheng(1)
'x方向起点已在原点，只在y方向平移一定的距离，使其起点也在原点上，
'然后，x ,y方向再放大相应的倍数， '以实现x ,y方向不同比例的缩放
'最后在移到原起始坐标上
For i = 0 To count \ 2
bakjuligaocheng(2 * i) = juligaocheng(2 * i) * 1000 / xscale
bakjuligaocheng(2 * i + 1) = (juligaocheng(2 * i + 1) - movevalue) * 1000 / yscale
bakjuligaocheng(2 * i + 1) = bakjuligaocheng(2 * i + 1) + (movevalue - min) * 1000 / yscale
bakjuligaocheng(2 * i) = bakjuligaocheng(2 * i) + point(0)
bakjuligaocheng(2 * i + 1) = bakjuligaocheng(2 * i + 1) + point(1)
Next
Set dmxpline = ThisDrawing.ModelSpace.AddLightWeightPolyline(bakjuligaocheng)
dmxpline.ConstantWidth = 0.12
End Sub
'3画数据栏
Private Sub shujulan(point As Variant, length As Double, zigao As Single, xscale As Double, mingc As Double)
Set shujulanlayer = ThisDrawing.Layers.Add("数据栏")
ThisDrawing.ActiveLayer = shujulanlayer
shujulanlayer.color = acCyan
Dim pt() As Double'动态数组
Dim plineobj As AcadLWPolyline
Dim textobj As AcadText
Dim textpoint(0 To 2) As Double '定义文字对起点
ReDim pt(0 To 7)
pt(0) = point(0): pt(1) = point(1)
pt(2) = pt(0) - 25: pt(3) = pt(1)
pt(4) = pt(2): pt(5) = pt(3) - 28
pt(6) = pt(0): pt(7) = pt(5)
Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
plineobj.Closed = True
ReDim pt(0 To 3)
pt(0) = point(0): pt(1) = point(1) - 14
pt(2) = pt(0) - 25: pt(3) = pt(1)
Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
textpoint(0) = point(0) - 12.5: textpoint(1) = point(1) - 7
Set textobj = ThisDrawing.ModelSpace.AddText("距 离(m)", textpoint, zigao)
textobj.Alignment = acAlignmentMiddleCenter
textobj.TextAlignmentPoint = textpoint
textpoint(1) = point(0) - 12.5: textpoint(1) = point(1) - 21
Set textobj = ThisDrawing.ModelSpace.AddText("高 程(m)", textpoint, zigao)
textobj.Alignment = acAlignmentMiddleCenter
textobj.TextAlignmentPoint = textpoint
ReDim pt(0 To 7)
pt(0) = point(0): pt(1) = point(1)
pt(2) = pt(0) + length * 1000 / xscale: pt(3) = pt(1)
pt(4) = pt(2): pt(5) = pt(3) - 28
pt(6) = pt(0): pt(7) = pt(5)
Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
ReDim pt(0 To 3)
pt(0) = point(0): pt(1) = point(1) - 14
pt(2) = pt(0) + length * 1000 / xscale: pt(3) = pt(1)
Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
'下面向数据栏里添加距离 高程数据
Dim min As Double
min = Int(mingc) - dy * ndy
Dim zhuanghao As Double '桩号 数据
Dim gaocheng As Double '高程 数据
Dim zhjltext As AcadText '桩号，高程文字
zhuanghao = juligaocheng(0)
gaocheng = juligaocheng(1) '----------------------------
textpoint(0) = point(0): textpoint(1) = point(1) - 7 '第一个桩号0+000 |
Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(zhuanghao, "0+000"), textpoint, zigao) '|
zhjltext.Alignment = acAlignmentTopCenter '|添
zhjltext.TextAlignmentPoint = textpoint '|
zhjltext.Rotation = 3.1415926 / 2
textpoint(1) = point(1) - 21 '第一个高程值
Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(gaocheng, "0.000"), textpoint, zigao)
zhjltext.Alignment = acAlignmentTopCenter '|
zhjltext.TextAlignmentPoint = textpoint '|
zhjltext.Rotation = 3.1415926 / 2 '|加
zhuanghao = dx '|
Do While zhuanghao < length '循环添加桩号和高程 '|桩
textpoint(0) = textpoint(0) + dx * 1000 / xscale: textpoint(1) = point(1) - 7 '|
Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(zhuanghao, "0+000"), textpoint, zigao) '|号
zhjltext.Alignment = acAlignmentBottomCenter '|
zhjltext.TextAlignmentPoint = textpoint '|
zhjltext.Rotation = 3.1415926 / 2 '|和
pt(0) = textpoint(0): pt(1) = point(1)
pt(2) = textpoint(0): pt(3) = point(1) - 28
Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
gaocheng = plineobj.IntersectWith(dmxpline, acExtendBoth)(1)'求交点，以获得高程值
gaocheng = (gaocheng - point(1)) * yscale / 1000 + min
textpoint(1) = point(1) - 21
Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(gaocheng, "0.000"), textpoint, zigao)
zhjltext.Alignment = acAlignmentBottomCenter '|高
zhjltext.TextAlignmentPoint = textpoint '|
zhjltext.Rotation = 3.1415926 / 2
zhuanghao = zhuanghao + dx
Loop '|
textpoint(0) = point(0) + length * 1000 / xscale: textpoint(1) = point(1) - 7 '最后一个桩号 '|
Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(length, "0+000.00"), textpoint, zigao) '|程
zhjltext.Alignment = acAlignmentBottomCenter '|
zhjltext.TextAlignmentPoint = textpoint '|
zhjltext.Rotation = 3.1415926 / 2 '|
pt(0) = textpoint(0): pt(1) = point(1)
pt(2) = textpoint(0): pt(3) = point(1) - 28
Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
gaocheng = plineobj.IntersectWith(dmxpline, acExtendBoth)(1) '最后一个桩号
gaocheng = (gaocheng - point(1)) * yscale / 1000 + min
textpoint(1) = point(1) - 21
Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(gaocheng, "0.000"), textpoint, zigao)
zhjltext.Alignment = acAlignmentBottomCenter '|
zhjltext.TextAlignmentPoint = textpoint '|
zhjltext.Rotation = 3.1415926 / 2
'----------------------------------- --|
'下面添加剖切线拐点桩号
Dim max As Double
Dim h As Double
max = Int(maxgc) + dy
h = max - min
If dy = 2 Then If h Mod 2 <> 0 Then h = h + 1
If dy = 5 Then If h Mod 5 <> 0 Then h = h - h Mod 5 + 5
If CheckBox3.value Then
If UBound(pqxdingdian) > 1 Then
Dim countguaidian As Integer
Dim i As Integer
countguaidian = UBound(pqxdingdian) - 1 '拐点个数
ReDim guaidian(countguaidian) As Double
For i = 1 To countguaidian
zhuanghao = pqxdingdian(i).distance
textpoint(0) = point(0) + zhuanghao * 1000 / xscale: textpoint(1) = point(1) - 7
Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(zhuanghao, "0+000.00"), textpoint, zigao)
zhjltext.Alignment = acAlignmentBottomCenter
zhjltext.TextAlignmentPoint = textpoint
zhjltext.Rotation = 3.1415926 / 2
zhjltext.color = acRed
pt(0) = textpoint(0): pt(1) = point(1)
pt(2) = textpoint(0): pt(3) = point(1) - 28
Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
plineobj.color = acRed
gaocheng = plineobj.IntersectWith(dmxpline, acExtendBoth)(1)
gaocheng = (gaocheng - point(1)) * yscale / 1000 + min
textpoint(1) = point(1) - 21
Set zhjltext = ThisDrawing.ModelSpace.AddText(Format(gaocheng, "0.000"), textpoint, zigao)
zhjltext.Alignment = acAlignmentBottomCenter
zhjltext.TextAlignmentPoint = textpoint
zhjltext.Rotation = 3.1415926 / 2
zhjltext.color = acRed
pt(3) = point(1) + h * 1000 / yscale
Set plineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
plineobj.color = acRed
textpoint(1) = point(1) + 2
Set zhjltext = ThisDrawing.ModelSpace.AddText("拐点" & i, textpoint, zigao)
zhjltext.Alignment = acAlignmentBottomLeft
zhjltext.TextAlignmentPoint = textpoint
zhjltext.Rotation = 3.1415926 / 2
zhjltext.color = acRed
Next
End If
End If
'下面添加标题名称 ，比例尺，和桩号距离
Set biaotilayer = ThisDrawing.Layers.Add("标题文字")
ThisDrawing.ActiveLayer = biaotilayer
biaochiganlayer.color = acGreen
Dim biaotitext As AcadText
textpoint(0) = point(0) + length * 1000 / xscale / 2
textpoint(1) = point(1) + (h + 2) * 1000 / yscale + 25
Set biaotitext = ThisDrawing.ModelSpace.AddText("1-2 纵 断 面 图", textpoint, 7)
biaotitext.Alignment = acAlignmentBottomCenter
biaotitext.TextAlignmentPoint = textpoint
textpoint(1) = textpoint(1) - 9
Set biaotitext = ThisDrawing.ModelSpace.AddText("水平 1:" & xscale, textpoint, 4)
textpoint(1) = textpoint(1) - 6
Set biaotitext = ThisDrawing.ModelSpace.AddText("垂直 1:" & yscale, textpoint, 4)
textpoint(0) = textpoint(0) - 11
textpoint(1) = textpoint(1) + 3
Set biaotitext = ThisDrawing.ModelSpace.AddText("比例 ", textpoint, 4)
End Sub
'求两点之间的距离,参数是x1,y1,x2,y2
Private Function distance(x1 As Double, y1 As Double, x2 As Double, y2 As Double) As Double
distance = ((x1 - x2) ^ 2 + (y1 - y2) ^ 2) ^ 0.5
End Function
'求两点之间的距离,参数是(x1,y1),(x2,y2)
Private Function distancep1p2(ByVal p1 As Variant, ByVal p2 As Variant) As Double
distancep1p2 = ((p1(0) - p2(0)) ^ 2 + (p1(1) - p2(1)) ^ 2) ^ 0.5
End Function
'计算并返回多段线上的一点到起始点的距离
Private Function plinedistancep1(xy As Variant, plineobj As AcadLWPolyline) As Double
Dim p1 As Variant
Dim p2 As Variant
Dim count As Integer, i As Integer 'i是多段线的线段索引编号
Dim d1 As Double, d2 As Double, d3 As Double
count = UBound(plineobj.Coordinates) \ 2
plinedistancep1 = 0
For i = 0 To count - 1
p1 = plineobj.Coordinate(i)
p2 = plineobj.Coordinate(i + 1)
d1 = distancep1p2(p1, xy)
d2 = distancep1p2(xy, p2)
d3 = distancep1p2(p1, p2)
plinedistancep1 = plinedistancep1 + d3
If Abs((d1 + d2 - d3) / d3) < 0.0001 Then '0.0001 越小越精确,但有时会出现莫名其妙的问题
plinedistancep1 = plinedistancep1 - d2
'MsgBox d1 & Chr(13) & d2 & Chr(13) & d1 + d2 & Chr(13) & d3
Exit For
End If
Next
End Function
'创建新的用户坐标系 “userucs”
Sub newuserucs(point As Variant)
'Dim ucsObj As AcadUCS
Dim origin(0 To 2) As Double
Dim xAxisPnt(0 To 2) As Double
Dim yAxisPnt(0 To 2) As Double
' 定义 UCS 点
origin(0) = point(0): origin(1) = point(1): origin(2) = 0
xAxisPnt(0) = point(0) + 1: xAxisPnt(1) = point(1): xAxisPnt(2) = 0
yAxisPnt(0) = point(0): yAxisPnt(1) = point(1) + 1: yAxisPnt(2) = 0
'创建新的用户坐标系，并激活新建用户坐标系
' 添加 UCS 到 UserCoordinatesSystems 集合中
ThisDrawing.ActiveUCS = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "userucs")
'ThisDrawing.Application.Update
End Sub
'恢复上一个坐标系
Private Sub userucstowcs()
ThisDrawing.SendCommand "_ucs" & vbCr & "p" & vbCr
End Sub
''创建新的字体样式
'Private Sub newtextstyle() '创建新的字体样式
' Dim typeFace As String
' Dim SavetypeFace As String
' Dim Bold As Boolean
' Dim Italic As Boolean
' Dim charSet As Long
' Dim PitchandFamily As Long
' Dim lkxtextstyle As AcadTextStyle
' Dim currenttextstyle As AcadTextStyle
' Set currenttextstyle = ThisDrawing.ActiveTextStyle
' '获取当前字体样式的参数
' currenttextstyle.GetFont typeFace, Bold, Italic, charSet, PitchandFamily
' Set lkxtextstyle = ThisDrawing.TextStyles.Add("wh_lkx")
' With lkxtextstyle
' .SetFont "宋体", False, False, charSet, PitchandFamily
' .width = 0.8 '设置宽度比例
' End With
'End Sub
Private Sub CommandButton4_Click()
MsgBox "时间：2012年2月06日 " & vbCr & _
"名称：地形图切剖面 V1.3 " & vbCr & _
"by：沙漠骆驼 " & vbCr & _
"qq：549738552 " & vbCr & vbCr & _
"当前时间：" & Date & vbCr & _
" " & Time, vbInformation, "地形图切剖面--by沙漠骆驼"
End Sub
Private Sub Label11_Click()
'选取等高线，以获取等高线所在的图层名称
On Error Resume Next
Me.Hide
quxiao '调用取消命令
ComboBox1.Enabled = False
Label1.Enabled = True
Dim plineobj As AcadEntity
Dim base As Variant
ThisDrawing.Utility.GetEntity plineobj, base, "请选取等高线，以获取等高线所在的图层名称:" & vbCrLf
If Err.Number <> 0 Or (plineobj.ObjectName <> "AcDb2dPolyline" And plineobj.ObjectName <> "AcDbPolyline") Then
ThisDrawing.Utility.prompt "-----等高线选取失败------" & vbCrLf
Me.show
Exit Sub
End If
ThisDrawing.Utility.prompt "-----获取等高线图层成功，请继续下一步操作，选取剖切线-----" & vbCrLf
dgxlayername = plineobj.Layer
Label1.Caption = dgxlayername
Me.height = 121 '改变窗体大小,274,121
Me.width = 225
Me.show
End Sub
Private Sub Label13_Click()
Me.height = 121
Me.width = 225
ComboBox1.Enabled = True
Label1.Enabled = False
ComboBox1.Clear
For Each layerobj In ThisDrawing.Layers
ComboBox1.AddItem Trim(layerobj.name)
Next
ComboBox1.Text = ComboBox1.List(0)
End Sub
Private Sub Label15_Click()
ListBox1.Clear
If pouqiefangxiang = True Then
For i = 1 To jiaodianzongshu
ListBox1.AddItem Format(i, "!@@@@@@") & jiaodian(i).z
Next
Else
For i = jiaodianzongshu To 1 Step -1
ListBox1.AddItem Format(jiaodianzongshu - i + 1, "!@@@@@@") & jiaodian(i).z
Next
End If
TextBox4.Text = maxgc
TextBox3.Text = mingc
Label15.Visible = False
Label16.Visible = True
Me.width = 330
End Sub
Private Sub Label16_Click()
On Error Resume Next
pptlive.Delete
If Error.Err Then Err.Clear
Label15.Visible = True
Label16.Visible = False
Me.width = 225
End Sub
Private Sub ListBox1_Click()
Dim i As Integer
On Error Resume Next
pptlive.Delete
i = Left(ListBox1.Text, 5)
If pouqiefangxiang = False Then i = jiaodianzongshu - i + 1
Dim zhongxin(0 To 11) As Double '定义交点坐标
zhongxin(0) = jiaodian(i).xy(0) - 2: zhongxin(1) = jiaodian(i).xy(1)
zhongxin(2) = jiaodian(i).xy(0) + 2: zhongxin(3) = jiaodian(i).xy(1)
zhongxin(4) = jiaodian(i).xy(0) - 2: zhongxin(5) = jiaodian(i).xy(1)
zhongxin(6) = jiaodian(i).xy(0) - 0.6: zhongxin(7) = jiaodian(i).xy(1)
zhongxin(8) = jiaodian(i).xy(0) + 0.6: zhongxin(9) = jiaodian(i).xy(1)
zhongxin(10) = jiaodian(i).xy(0) - 0.6: zhongxin(11) = jiaodian(i).xy(1)
If Error.Err Then Err.Clear
Set pptlive = ThisDrawing.ModelSpace.AddLightWeightPolyline(zhongxin)
With pptlive
.SetWidth 0, 0.5, 0.5
.SetWidth 1, 0.5, 0.5
.SetWidth 2, 0, 0
.SetWidth 3, 1.2, 1.2
.SetWidth 4, 1.2, 1.2
.SetBulge 0, 1
.SetBulge 1, 1
.SetBulge 3, 1
.SetBulge 4, 1
.color = acGreen
End With
Dim box1 As Variant
Dim box2 As Variant
pptlive.GetBoundingBox box1, box2
box1(0) = box1(0): box1(1) = box1(1) - 40
box2(0) = box2(0) + 100: box2(1) = box2(1) + 60
ThisDrawing.Application.ZoomWindow box1, box2
End Sub
Private Sub UserForm_Initialize()
ComboBox1.Clear '设置图层
For Each layerobj In ThisDrawing.Layers
ComboBox1.AddItem layerobj.name
Next
ComboBox1.Text = ThisDrawing.Layers.Item(0).name
Dim i As Integer
For i = 1 To 9'设置字体高度
ComboBox4.AddItem Format(i / 2 + 0.5, "0.0")
Next
ComboBox2.AddItem 1
ComboBox2.AddItem 2
ComboBox2.AddItem 5
ComboBox2.AddItem 10 '设置垂直比例
ComboBox2.AddItem 20
ComboBox2.AddItem 25
ComboBox2.AddItem 50
For i = 3 To 6
ComboBox2.AddItem 10 * ComboBox2.List(i)
Next
For i = 3 To 6
ComboBox2.AddItem 100 * ComboBox2.List(i)
Next
For i = 3 To 6
ComboBox2.AddItem 1000 * ComboBox2.List(i)
Next
ComboBox3.AddItem 1
ComboBox3.AddItem 2
ComboBox3.AddItem 5
ComboBox3.AddItem 10 '设置水平比例
ComboBox3.AddItem 20
ComboBox3.AddItem 25
ComboBox3.AddItem 50
For i = 3 To 6
ComboBox3.AddItem 10 * ComboBox3.List(i)
Next
For i = 3 To 6
ComboBox3.AddItem 100 * ComboBox3.List(i)
Next
For i = 3 To 6
ComboBox3.AddItem 1000 * ComboBox3.List(i)
Next
ComboBox5.AddItem "01m" '设置高程间隔距离
ComboBox5.AddItem "02m"
ComboBox5.AddItem "05m"
ComboBox5.AddItem "10m"
ComboBox5.AddItem "20m"
ComboBox5.AddItem "25m"
ComboBox5.AddItem "40m"
ComboBox5.AddItem "50m"
'设置桩号间距
ComboBox6.AddItem 5
ComboBox6.AddItem 10
ComboBox6.AddItem 20
ComboBox6.AddItem 25
For i = 0 To 3
ComboBox6.AddItem 10 * ComboBox6.List(i)
Next
For i = 0 To 3
ComboBox6.AddItem 100 * ComboBox6.List(i)
Next
'设置标尺干的超出长度，为 n * dy
For i = 1 To 10
ComboBox7.AddItem i
Next
newtextstyle2 '调用新建字体样式程序
Me.height = 121
Me.width = 225
dgxlayername = ""
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
pptlive.Delete
If Error.Err Then Err.Clear
End Sub
谢谢，学习一下。可贵的是都是vba的。 感谢无私分享！
感谢无私分享！ 感谢无私分享！ 你好，请问这个哦工具的命令是什么呢，本人刚开始学习中
感谢无私分享！ 非常不错的代码，谢谢楼主分享吖 脑壳都看麻了，我的天呀
页:
[1]