沙漠骆驼工具箱源码-20 绘制WES剖面曲线（三段复合圆弧型）
工具条： 绘制WES剖面曲线
1 界面
2 代码如下：
Option Explicit '强制要求变量声明
Dim hd As Double'定义设计水头Hd
Dim n As Double '定义上游堰坡指数
Dim k As Double'定义系数k
Dim r1 As Double '定义三段圆弧半径
Dim r2 As Double
Dim r3 As Double
Dim x As Double'定义x,y 坐标
Dim y As Double
Dim weslayer As AcadLayer
Dim zigao As Single
Dim beishu As Integer
Dim oldtuxinggeshu As Double'定义画曲线之前 的图形个数
Dim newtuxinggeshu As Double'定义画曲线之 后的图形个数
Dim biaozhuobj As AcadDimAligned
Dim dimpoint1(0 To 2) As Double
Dim dimpoint2(0 To 2) As Double
Dim dimlocation(0 To 2) As Double
Dim xydian(0 To 2) As Double
Private Sub CommandButton1_Click()
Me.Hide
On Error Resume Next
oldtuxinggeshu = ThisDrawing.ModelSpace.count
If Trim(TextBox1.Text) = "" Or Trim(TextBox2.Text) = "" Or Trim(TextBox3.Text) = "" Then
MsgBox "请输入必要的数据", vbCritical, "警告--by沙漠骆驼"
Me.show
Exit Sub
End If
Set weslayer = ThisDrawing.Layers.Add("WES剖面")
weslayer.color = acGreen
ThisDrawing.SetVariable "cecolor", "256" '颜色bylayer
newtextstyle2 '调用新建字体样式程序
ThisDrawing.SetVariable "textstyle", "wh_lkx"
With weslayer
.LayerOn = True
.Lock = False
.Freeze = False
End With
ThisDrawing.ActiveLayer = weslayer
hd = TextBox1.Text
n = TextBox2.Text
k = TextBox3.Text
r1 = 0.5 * hd
r2 = 0.2 * hd
r3 = 0.04 * hd
beishu = ComboBox2.Text
Dim basepoint As Variant
Dim qidian(0 To 2) As Double
Dim zhongdian(0 To 2) As Double
Dim yuanxin(0 To 2) As Double
basepoint = ThisDrawing.Utility.GetPoint(, "请拾取插入点:")
qidian(0) = basepoint(0)
qidian(1) = basepoint(1)
Dim templine As AcadLine '定义临时线
yuanxin(0) = qidian(0)
yuanxin(1) = qidian(1) - r1
zhongdian(0) = yuanxin(0) - 0.175 * hd
zhongdian(1) = yuanxin(1) + (r1 ^ 2 - (0.175 * hd) ^ 2) ^ 0.5
Dim wesquxian As AcadArc
Dim banjingyinxian(0 To 5) As Double
Dim xianduanzhongdian(0 To 2) As Double
'画第一段圆弧
Set wesquxian = addarc1(yuanxin, qidian, zhongdian)
'Set templine = ThisDrawing.ModelSpace.AddLine(yuanxin, qidian)
Set templine = ThisDrawing.ModelSpace.AddLine(yuanxin, zhongdian) '画的是第一条半径
'添加半径引线R1
banjingyinxian(0) = (yuanxin(0) + zhongdian(0)) / 2
banjingyinxian(1) = (yuanxin(1) + zhongdian(1)) / 2
banjingyinxian(2) = banjingyinxian(0) - 1
banjingyinxian(3) = banjingyinxian(1) - 1
banjingyinxian(4) = banjingyinxian(2) - 0.35
banjingyinxian(5) = banjingyinxian(3)
ThisDrawing.ModelSpace.AddLightWeightPolyline (banjingyinxian)
xydian(0) = banjingyinxian(4) + 0.03
xydian(1) = banjingyinxian(5) + 0.03
ThisDrawing.ModelSpace.AddText "R1", xydian, 0.2
'添加标注B1
dimpoint1(0) = basepoint(0)
dimpoint1(1) = basepoint(1) + 0.2
dimpoint2(0) = zhongdian(0)
dimpoint2(1) = basepoint(1) + 0.2
dimlocation(0) = dimpoint2(0)
dimlocation(1) = (dimpoint1(1) + dimpoint2(1)) / 2 + 0.3
Set biaozhuobj = ThisDrawing.ModelSpace.AddDimAligned(dimpoint1, dimpoint2, dimlocation)
With biaozhuobj
.ArrowheadSize = 0.06 * beishu '箭头的尺寸
.TextHeight = 0.2 * beishu '指定标注文字高度
.ExtensionLineExtend = 0.1 * beishu '尺寸界线超出尺寸线的距离
.ExtLineFixedLenSuppress = True '打开固定尺寸界线开关
.ExtLineFixedLen = 0.1 * beishu '尺寸界线固定长度
.TextOverride = "B1"
.TextStyle = "wh_lkx"
.scalefactor = 1
.TextGap = 0' 放入标注文字时，标注文字与尺寸线之间的距离。
'.TextPosition = dimlocation
End With
'画第二段圆弧
Dim tempcircle As AcadCircle'定义临时圆
Dim linshidian(0 To 2) As Double '定义临时点
Dim linshijiaodian As Variant '定义临时的交点 linshijiaodian
Set tempcircle = ThisDrawing.ModelSpace.AddCircle(zhongdian, r2)
linshijiaodian = tempcircle.IntersectWith(templine, acExtendNone) '求圆心
tempcircle.Delete
yuanxin(0) = linshijiaodian(0)
yuanxin(1) = linshijiaodian(1)
qidian(0) = zhongdian(0)
qidian(1) = zhongdian(1)
zhongdian(0) = qidian(0) - (0.276 * hd - 0.175 * hd)
zhongdian(1) = yuanxin(1)
linshidian(0) = zhongdian(0)
linshidian(1) = qidian(1)
Set templine = ThisDrawing.ModelSpace.AddLine(zhongdian, linshidian)
Set tempcircle = ThisDrawing.ModelSpace.AddCircle(yuanxin, r2)
linshijiaodian = tempcircle.IntersectWith(templine, acExtendNone)
zhongdian(0) = linshijiaodian(0)
zhongdian(1) = linshijiaodian(1)
templine.Delete
tempcircle.Delete
Set wesquxian = addarc1(yuanxin, qidian, zhongdian)
Set templine = ThisDrawing.ModelSpace.AddLine(yuanxin, zhongdian)
'添加半径引线R2
banjingyinxian(0) = (yuanxin(0) + zhongdian(0)) / 2
banjingyinxian(1) = (yuanxin(1) + zhongdian(1)) / 2
banjingyinxian(2) = banjingyinxian(2)
banjingyinxian(3) = banjingyinxian(3) + 0.4
banjingyinxian(4) = banjingyinxian(2) - 0.35
banjingyinxian(5) = banjingyinxian(3)
ThisDrawing.ModelSpace.AddLightWeightPolyline (banjingyinxian)
xydian(0) = banjingyinxian(4) + 0.03
xydian(1) = banjingyinxian(5) + 0.03
ThisDrawing.ModelSpace.AddText "R2", xydian, 0.2
'添加标注B2
dimpoint1(0) = basepoint(0)
dimpoint1(1) = basepoint(1) + 0.5
dimpoint2(0) = zhongdian(0)
dimpoint2(1) = basepoint(1) + 0.5
dimlocation(0) = dimpoint2(0)
dimlocation(1) = (dimpoint1(1) + dimpoint2(1)) / 2 + 0.3
Set biaozhuobj = ThisDrawing.ModelSpace.AddDimAligned(dimpoint1, dimpoint2, dimlocation)
With biaozhuobj
.ArrowheadSize = 0.06 * beishu '箭头的尺寸
.TextHeight = 0.2 * beishu '指定标注文字高度
.ExtensionLineExtend = 0.1 * beishu '尺寸界线超出尺寸线的距离
.ExtLineFixedLenSuppress = True '打开固定尺寸界线开关
.ExtLineFixedLen = 0.1 * beishu'尺寸界线固定长度
.TextOverride = "B2"
.TextStyle = "wh_lkx"
.scalefactor = 1
.TextGap = 0
'.TextPosition = dimlocation
End With
'画第三段圆弧
Set tempcircle = ThisDrawing.ModelSpace.AddCircle(zhongdian, r3)
linshijiaodian = tempcircle.IntersectWith(templine, acExtendNone) '求圆心
tempcircle.Delete
yuanxin(0) = linshijiaodian(0)
yuanxin(1) = linshijiaodian(1)
qidian(0) = zhongdian(0)
qidian(1) = zhongdian(1)
zhongdian(0) = yuanxin(0) - r3
zhongdian(1) = yuanxin(1)
Set wesquxian = addarc1(yuanxin, qidian, zhongdian)
Set templine = ThisDrawing.ModelSpace.AddLine(yuanxin, zhongdian)
'添加半径引线R3
banjingyinxian(0) = (yuanxin(0) + zhongdian(0)) / 2
banjingyinxian(1) = (yuanxin(1) + zhongdian(1)) / 2
banjingyinxian(2) = banjingyinxian(2)
banjingyinxian(3) = banjingyinxian(3) + 0.4
banjingyinxian(4) = banjingyinxian(2) - 0.35
banjingyinxian(5) = banjingyinxian(3)
ThisDrawing.ModelSpace.AddLightWeightPolyline (banjingyinxian)
xydian(0) = banjingyinxian(4) + 0.03
xydian(1) = banjingyinxian(5) + 0.03
ThisDrawing.ModelSpace.AddText "R3", xydian, 0.2
'添加标注B3
dimpoint1(0) = basepoint(0)
dimpoint1(1) = basepoint(1) + 0.8
dimpoint2(0) = zhongdian(0)
dimpoint2(1) = basepoint(1) + 0.8
dimlocation(0) = dimpoint2(0)
dimlocation(1) = (dimpoint1(1) + dimpoint2(1)) / 2 + 0.3
Set biaozhuobj = ThisDrawing.ModelSpace.AddDimAligned(dimpoint1, dimpoint2, dimlocation)
With biaozhuobj
.ArrowheadSize = 0.06 * beishu '箭头的尺寸
.TextHeight = 0.2 * beishu '指定标注文字高度
.ExtensionLineExtend = 0.1 * beishu '尺寸界线超出尺寸线的距离
.ExtLineFixedLenSuppress = True '打开固定尺寸界线开关
.ExtLineFixedLen = 0.1 * beishu '尺寸界线固定长度
.TextOverride = "B3"
.TextStyle = "wh_lkx"
.scalefactor = 1
.TextGap = 0 ' 放入标注文字时，标注文字与尺寸线之间的距离。
'.TextPosition = dimlocation
End With
'添加标注Hd
dimpoint1(0) = basepoint(0)
dimpoint1(1) = basepoint(1)
dimpoint2(0) = dimpoint1(0)
dimpoint2(1) = dimpoint1(1) + hd
dimlocation(0) = basepoint(0) - 1.3
dimlocation(1) = (dimpoint1(1) + dimpoint2(1)) / 2
Set biaozhuobj = ThisDrawing.ModelSpace.AddDimAligned(dimpoint1, dimpoint2, dimlocation)
With biaozhuobj
.ArrowheadSize = 0.06 * beishu '箭头的尺寸
.TextHeight = 0.2 * beishu '指定标注文字高度
.ExtensionLineExtend = 0.1 * beishu '尺寸界线超出尺寸线的距离
.ExtLineFixedLenSuppress = True '打开固定尺寸界线开关
.ExtLineFixedLen = 0.1 * beishu '尺寸界线固定长度
.TextOverride = "Hd"
.TextStyle = "wh_lkx"
.scalefactor = 1
.TextRotation = 0.0001
.TextGap = 0
End With
linshidian(0) = zhongdian(0) '画左边的竖线
If hd >= 1 Then
linshidian(1) = basepoint(1) - 6
ElseIf hd >= 0.7 Then
linshidian(1) = basepoint(1) - 10 * hd
ElseIf hd >= 0.4 Then
linshidian(1) = basepoint(1) - 25 * hd
ElseIf hd > 0.2 Then
linshidian(1) = basepoint(1) - 50 * hd
Else
linshidian(1) = basepoint(1) - 100 * hd
End If
ThisDrawing.ModelSpace.AddLine zhongdian, linshidian
'下面绘制幂曲线 x 画到4m 81个坐标点 就差不多了
'Dim miquxian As AcadLWPolyline
Dim points(0 To 161) As Double
Dim i As Double
' 定义二维多段线顶点，x值增量为0.05m,5cm
x = 0
For i = 0 To 80 Step 1
y = x ^ n / k / hd ^ (n - 1)
points(i * 2) = x + basepoint(0)
points(i * 2 + 1) = -1 * y + basepoint(1)
x = x + 0.05
Next
ThisDrawing.ModelSpace.AddLightWeightPolyline (points)
'下面画坐标轴
'画横轴
Dim linelist(0 To 5) As Double
linelist(0) = basepoint(0): linelist(1) = basepoint(1)
linelist(2) = basepoint(0) + 3
linelist(3) = basepoint(1)
linelist(4) = basepoint(0) + 3.4: linelist(5) = basepoint(1)
Dim jiantou As AcadLWPolyline
Set jiantou = ThisDrawing.ModelSpace.AddLightWeightPolyline(linelist)
jiantou.SetWidth 1, 0.1, 0
jiantou.color = acRed
xydian(0) = basepoint(0) + 3.5
xydian(1) = basepoint(1)
ThisDrawing.ModelSpace.AddText "x", xydian, 0.35
'画竖轴
linelist(0) = basepoint(0): linelist(1) = basepoint(1)
linelist(2) = basepoint(0)
linelist(3) = basepoint(1) - 3
linelist(4) = basepoint(0): linelist(5) = basepoint(1) - 3.4
Set jiantou = ThisDrawing.ModelSpace.AddLightWeightPolyline(linelist)
jiantou.SetWidth 1, 0.1, 0
jiantou.color = acRed
xydian(0) = basepoint(0) + 0.2
xydian(1) = basepoint(1) - 3.5
ThisDrawing.ModelSpace.AddText "y", xydian, 0.35
newtuxinggeshu = ThisDrawing.ModelSpace.count
' 放大剖面曲线
For i = oldtuxinggeshu To newtuxinggeshu - 1
ThisDrawing.ModelSpace.Item(i).ScaleEntity basepoint, beishu
Next
'下面插入幂曲线表格
For i = 0 To 80 Step 1
points(i * 2) = points(i * 2) - basepoint(0)
points(i * 2 + 1) = points(i * 2 + 1) - basepoint(1)
Next
newtextstyle2 '调用新建字体样式程序
ThisDrawing.SetVariable "textstyle", "wh_lkx"
zigao = ComboBox1.Text
basepoint = ThisDrawing.Utility.GetPoint(, "请拾取坐标表格插入点:")
Dim biaotoukuan As Double '定义表格宽度
Dim biaotougao As Double '定义表格高度
If zigao < 4 Then
biaotoukuan = 20
biaotougao = 8
Else
biaotoukuan = zigao * 8
biaotougao = zigao * 2.5
End If
Dim hengxian As AcadLWPolyline
Dim p1p2(0 To 3) As Double
p1p2(0) = basepoint(0): p1p2(1) = basepoint(1)
p1p2(2) = basepoint(0) + 2 * biaotoukuan: p1p2(3) = p1p2(1)
ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
p1p2(0) = basepoint(0): p1p2(1) = basepoint(1) - biaotougao
p1p2(2) = basepoint(0) + 2 * biaotoukuan: p1p2(3) = p1p2(1)
ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
'====================================
'下面画表格
For i = 0 To 40
p1p2(0) = basepoint(0)
p1p2(1) = p1p2(1) - biaotougao
p1p2(2) = basepoint(0) + 2 * biaotoukuan
p1p2(3) = p1p2(1)
ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
Next
For i = 0 To 2
p1p2(0) = basepoint(0) + biaotoukuan * i
p1p2(1) = basepoint(1)
p1p2(2) = p1p2(0)
ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
Next
'下面插入数据
Dim mingcheng As AcadText
Dim charudian(0 To 2) As Double
charudian(0) = basepoint(0) + biaotoukuan * 0.5
charudian(1) = basepoint(1) - biaotougao * 0.5
Set mingcheng = ThisDrawing.ModelSpace.AddText("x坐标(cm)", charudian, zigao)
With mingcheng
.Alignment = acAlignmentMiddleCenter
.TextAlignmentPoint = charudian
End With
charudian(0) = basepoint(0) + biaotoukuan * 1.5
charudian(1) = basepoint(1) - biaotougao * 0.5
Set mingcheng = ThisDrawing.ModelSpace.AddText("y坐标(cm)", charudian, zigao)
mingcheng.Alignment = acAlignmentMiddleCenter
mingcheng.TextAlignmentPoint = charudian
' 重新定义二维多段线顶点，x值增量为0.1m,10cm
' x = 0
' For i = 0 To 40 Step 1
' y = x ^ n / k / hd ^ (n - 1)
' points(i * 2) = x
' points(i * 2 + 1) = -1 * y
' x = x + 0.1
' Next
'插入编号及x y坐标
x = 0
For i = 1 To 41
charudian(0) = basepoint(0) + biaotoukuan * 0.5
charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
Set mingcheng = ThisDrawing.ModelSpace.AddText(x * 100, charudian, zigao)
mingcheng.Alignment = acAlignmentMiddleCenter
mingcheng.TextAlignmentPoint = charudian
charudian(0) = basepoint(0) + biaotoukuan * 1.5
charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
Set mingcheng = ThisDrawing.ModelSpace.AddText(Format(x ^ n / k / hd ^ (n - 1) * 100, "0.0"), charudian, zigao)
mingcheng.Alignment = acAlignmentMiddleCenter
mingcheng.TextAlignmentPoint = charudian
x = x + 0.1
Next
charudian(0) = basepoint(0)
charudian(1) = basepoint(1) + biaotougao
Dim mtextobj As AcadMText
Dim textstring As String
textstring = "幂曲线方程: x{\H0.5x;\S" & n & ";}=" & k & hd & "{\H0.5x;\S" & n - 1 & ";} y"
Set mtextobj = ThisDrawing.ModelSpace.AddMText(charudian, 0, textstring)
mtextobj.height = zigao
'上游堰面曲线参数
basepoint(0) = basepoint(0) + 3 * biaotoukuan
basepoint(1) = basepoint(1)
basepoint(2) = 0
p1p2(1) = basepoint(1)
'下面画表格
For i = 0 To 3
p1p2(0) = basepoint(0)
p1p2(2) = basepoint(0) + 4 * biaotoukuan
p1p2(3) = p1p2(1)
ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
p1p2(1) = p1p2(1) - biaotougao
Next
For i = 0 To 4
p1p2(0) = basepoint(0) + biaotoukuan * i
p1p2(1) = basepoint(1)
p1p2(2) = p1p2(0)
ThisDrawing.ModelSpace.AddLightWeightPolyline p1p2
Next
For i = 0 To 2
charudian(0) = basepoint(0) + biaotoukuan * 0.5
charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
Set mingcheng = ThisDrawing.ModelSpace.AddText("R" & i + 1, charudian, zigao)
mingcheng.Alignment = acAlignmentMiddleCenter
mingcheng.TextAlignmentPoint = charudian
charudian(0) = basepoint(0) + biaotoukuan * 2.5
charudian(1) = basepoint(1) - (i + 0.5) * biaotougao
Set mingcheng = ThisDrawing.ModelSpace.AddText("B" & i + 1, charudian, zigao)
mingcheng.Alignment = acAlignmentMiddleCenter
mingcheng.TextAlignmentPoint = charudian
x = x + 0.1
Next
charudian(0) = basepoint(0) + biaotoukuan * 1.5
charudian(1) = basepoint(1) - 0.5 * biaotougao
Set mingcheng = ThisDrawing.ModelSpace.AddText(Format(r1, "0.000"), charudian, zigao)
mingcheng.Alignment = acAlignmentMiddleCenter
mingcheng.TextAlignmentPoint = charudian
charudian(0) = basepoint(0) + biaotoukuan * 1.5
charudian(1) = basepoint(1) - 1.5 * biaotougao
Set mingcheng = ThisDrawing.ModelSpace.AddText(Format(r2, "0.000"), charudian, zigao)
mingcheng.Alignment = acAlignmentMiddleCenter
mingcheng.TextAlignmentPoint = charudian
charudian(0) = basepoint(0) + biaotoukuan * 1.5
charudian(1) = basepoint(1) - 2.5 * biaotougao
Set mingcheng = ThisDrawing.ModelSpace.AddText(Format(r3, "0.000"), charudian, zigao)
mingcheng.Alignment = acAlignmentMiddleCenter
mingcheng.TextAlignmentPoint = charudian
charudian(0) = basepoint(0) + biaotoukuan * 3.5
charudian(1) = basepoint(1) - 0.5 * biaotougao
Set mingcheng = ThisDrawing.ModelSpace.AddText(Format(0.175 * hd, "0.000"), charudian, zigao)
mingcheng.Alignment = acAlignmentMiddleCenter
mingcheng.TextAlignmentPoint = charudian
charudian(0) = basepoint(0) + biaotoukuan * 3.5
charudian(1) = basepoint(1) - 1.5 * biaotougao
Set mingcheng = ThisDrawing.ModelSpace.AddText(Format(0.276 * hd, "0.000"), charudian, zigao)
mingcheng.Alignment = acAlignmentMiddleCenter
mingcheng.TextAlignmentPoint = charudian
charudian(0) = basepoint(0) + biaotoukuan * 3.5
charudian(1) = basepoint(1) - 2.5 * biaotougao
Set mingcheng = ThisDrawing.ModelSpace.AddText(Format(0.2818 * hd, "0.000"), charudian, zigao)
mingcheng.Alignment = acAlignmentMiddleCenter
mingcheng.TextAlignmentPoint = charudian
charudian(0) = basepoint(0)
charudian(1) = basepoint(1) + biaotougao * 0.5
Set mingcheng = ThisDrawing.ModelSpace.AddText("上游堰面曲线参数(单位:m)By 沙漠骆驼(WHLKX)", charudian, zigao)
Me.show
End Sub
Private Sub CommandButton2_Click()
Me.Hide
End Sub
Private Sub TextBox1_Change()
On Error Resume Next
If Val(TextBox1.Text) <> TextBox1.Text Then
TextBox1.Text = ""
Exit Sub
End If
hd = TextBox1.Text
r1 = 0.5 * hd
r2 = 0.2 * hd
r3 = 0.04 * hd
Label5.Caption = Format(r1, "0.000")
Label6.Caption = Format(r2, "0.000")
Label8.Caption = Format(r3, "0.000")
End Sub
Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Me.Hide
Me.show vbModal
End Sub
Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Me.Hide
Me.show vbModal
End Sub
Private Sub TextBox3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Me.Hide
Me.show vbModal
End Sub
Private Sub UserForm_Initialize()
hd = TextBox1.Text
r1 = 0.5 * hd
r2 = 0.2 * hd
r3 = 0.04 * hd
Label5.Caption = Format(r1, "0.000")
Label6.Caption = Format(r2, "0.000")
Label8.Caption = Format(r3, "0.000")
Dim i As Integer
For i = 1 To 19'设置字体高度
ComboBox1.AddItem Format(i / 2 + 0.5, "0.0")
Next
For i = 15 To 95 Step 5'15---95
ComboBox1.AddItem i
Next
For i = 100 To 1000 Step 50 '100---500
ComboBox1.AddItem i
Next
ComboBox2.AddItem 1 '设置放大系数
ComboBox2.AddItem 10
ComboBox2.AddItem 50
ComboBox2.AddItem 100
ComboBox2.AddItem 200
ComboBox2.AddItem 500
ComboBox2.AddItem 1000
End Sub
页:
[1]