autocad2000.bas

行业软件,该源代码为道路设计纵断面典型的计算程序,该程序界面友好,计算准确,值得借鉴

    For j = 1 To 2
ReDim points(0 To 3) As Double
    points(0) = Choose(j, _
      SjZhS(i) - SjGcTs(i), SjZhS(i) + SjGcTs(i))
    points(1) = SjGc(CSng(points(0)))
    points(2) = SjZhS(i) + Choose(j, _
    -1, 1) * CDbl(HxBl) / 1000
    points(3) = SjBgS(i)
    points(0) = ZhuangHaoToZB(CSng(points(0)))
    points(1) = GcTOZB(CSng(points(1)))
    points(2) = ZhuangHaoToZB(CSng(points(2)))
    points(3) = GcTOZB(CSng(points(3)))
    Set objPline = ThisDrawing.ModelSpace. _
    AddLightWeightPolyline(points)
    objPline.Linetype = "DASHED"
    objPline.LinetypeScale = CDbl(HxBl) / 100
    objPline.Update
  Next j
  Dim objCircle As AcadCircle
  ReDim points(0 To 2) As Double
  Dim Radius As Double
  points(0) = ZhuangHaoToZB(SjZhS(i))
  points(1) = GcTOZB(SjBgS(i))
  Radius = CDbl(HxBl) / 1000#
  Set objCircle = ThisDrawing.ModelSpace. _
  AddCircle(points, Radius)
  objCircle.Color = acGreen
Next i

'************

Dim objBlockRef As AcadBlockReference
ReDim points(0 To 2) As Double
points(0) = ZhuangHaoToZB(SjZhS(1))
points(1) = GcTOZB(SjBgS(1))
points(2) = 0
Dim yScale As Double
yScale = CDbl(HxBl) / CDbl(ZxBl)
Set objBlockRef = ThisDrawing.ModelSpace.InsertBlock _
   (points, "zdmSheJiXian", 1#, yScale, 1#, 0#)
End Sub

Public Sub AddShuQuXian()
Dim i As Integer
Dim points() As Double
For i = 2 To SjNums - 1
ReDim points(0 To 7) As Double

points(0) = ZhuangHaoToZB(SjZhS(i) - SjGcTs(i))
points(1) = 150 + IIf(IsUp(i), 5, -5)
points(1) = points(1) * CDbl(HxBl) / 1000#
points(2) = points(0)
points(3) = 150 * CDbl(HxBl) / 1000#
points(4) = ZhuangHaoToZB(SjZhS(i) + SjGcTs(i))
points(5) = points(3)
points(6) = points(4)
points(7) = points(5) + IIf(IsUp(i), 5, -5) _
     * CDbl(HxBl) / 1000#
Dim objPline As AcadLWPolyline
Set objPline = ThisDrawing.ModelSpace. _
    AddLightWeightPolyline(points)
objPline.ConstantWidth = 0.7 * CDbl(HxBl) / 1000
Dim objMtext As AcadMText
Dim txtStr As String
ReDim points(0 To 2) As Double
txtStr = "R=" & SjRs(i)
txtStr = txtStr & " T=" & Format(SjGcTs(i), "#0.000")
txtStr = txtStr & " E=" & Format(SjGcEs(i), "#0.000")
points(0) = ZhuangHaoToZB(SjZhS(i)) - 20 * CDbl(HxBl) / 1000
points(1) = (150 + IIf(IsUp(i), 9, -5)) * CDbl(HxBl) / 1000
points(2) = 0
Set objMtext = ThisDrawing.ModelSpace.AddMText(points, 400, txtStr)
objMtext.Height = 4 * CDbl(HxBl) / 1000
objMtext.AttachmentPoint = acAttachmentPointMiddleLeft

If (SjGcTs(i) <= 0.1) Then objPline.Delete: objMtext.Delete
Next i
     
End Sub

Public Sub AddPoDuPoChang()
Dim i As Integer
Dim points() As Double
For i = 2 To SjNums - 1
ReDim points(0 To 3) As Double
points(0) = ZhuangHaoToZB(SjZhS(i))
points(1) = 120 * CDbl(HxBl) / 1000
points(2) = points(0)
points(3) = points(1) + 20 * CDbl(HxBl) / 1000
Dim objPline As AcadLWPolyline
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline _
   (points)
Next i
'********
For i = 1 To SjNums
ReDim points(0 To 2)
points(0) = IIf(i > 1, ZhuangHaoToZB(SjZhS(i)) - 12, _
  ZhuangHaoToZB(SjZhS(i)) - 12 + 4 * CDbl(HxBl) / 1000)
points(1) = 135 * CDbl(HxBl) / 1000
points(2) = 0
Dim txtStr As String
Dim objMtext As AcadMText
txtStr = CBg(CStr(SjBgS(i)))
Set objMtext = ThisDrawing.ModelSpace.AddMText(points, _
    24, txtStr)
objMtext.Height = 4 * CDbl(HxBl) / 1000#
objMtext.AttachmentPoint = acAttachmentPointBottomCenter
objMtext.Rotation = PI / 2
Next i
For i = 1 To SjNums - 1
ReDim points(0 To 3) As Double
points(0) = ZhuangHaoToZB(SjZhS(i))
points(1) = Switch((SjBgS(i + 1) > SjBgS(i)), 120, _
   (SjBgS(i + 1) = SjBgS(i)), 130, _
   (SjBgS(i + 1) < SjBgS(i)), 140) _
* CDbl(HxBl) / 1000
points(2) = ZhuangHaoToZB(SjZhS(i + 1))
points(3) = Switch((SjBgS(i + 1) > SjBgS(i)), 140, _
   (SjBgS(i + 1) = SjBgS(i)), 130, _
   (SjBgS(i + 1) < SjBgS(i)), 120) _
* CDbl(HxBl) / 1000
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline _
   (points)
Next i

For i = 1 To SjNums - 1
ReDim points(0 To 2)
Dim j As Integer
For j = 1 To 2
points(0) = ZhuangHaoToZB((SjZhS(i + 1) + SjZhS(i)) / 2) _
    - Choose(j, 6, 4) * CDbl(HxBl) / 1000#
points(1) = Choose(j, 129, 135) * CDbl(HxBl) / 1000
points(2) = 0
txtStr = Choose(j, Format(SjGcLs(i), "#0.000"), _
  Format(SjGcis(i) * 100, "#0.00"))
Set objMtext = ThisDrawing.ModelSpace.AddMText(points, _
    24, txtStr)
objMtext.Height = 4 * CDbl(HxBl) / 1000#
objMtext.AttachmentPoint = acAttachmentPointBottomLeft
Next j
Next i
For i = 1 To 5
points(0) = ZhuangHaoToZB(SjZhS(SjNums)) _
    + 20 * CDbl(HxBl) / 1000#
points(1) = Choose(i, 200, 180, 160, 140, 120) _
    * CDbl(HxBl) / 1000
points(2) = 0
txtStr = Choose(i, "地面线", "设计线", "变坡点", "切线", _
"附注：\P" & "1.本图标高为黄海高程系统。\P" & _
"2.本图桩号单位为m。\P" & "3.本图比例竖直方向为1:" & ZxBl _
& ", 横向为1:" & HxBl & "。")
  
Set objMtext = ThisDrawing.ModelSpace.AddMText(points, _
    150 * CDbl(HxBl) / 1000, txtStr)
objMtext.Height = 5 * CDbl(HxBl) / 1000#
objMtext.AttachmentPoint = acAttachmentPointTopLeft
Next

End Sub

Public Sub TiaoShuQuXian()
Dim pickLine1 As AcadLine
Dim pickLine2 As AcadLine
Dim pickPnt As Variant
'ThisDrawing.Utility.GetEntity pickLine1, pickPnt, "第一条线:"
'ThisDrawing.Utility.GetEntity pickLine2, pickPnt, "第二条线:"
ThisDrawing.SendCommand "_fillet" & vbCr & "r"
ThisDrawing.SendCommand "l" & vbCr
End Sub
'已知两条直线、半径求椭园弧
Public Sub ZhiXianYuanHu()
Dim pickLine1 As AcadLine
Dim pickLine2 As AcadLine
Dim pickPnt0 As Variant, pickPnt1 As Variant
Dim ShuQuXianR As Double
Dim Ratio As Double
ThisDrawing.Utility.GetEntity pickLine1, pickPnt0, "第一条线:"
ThisDrawing.Utility.GetEntity pickLine2, pickPnt1, "第二条线:"
ShuQuXianR = ThisDrawing.Utility.GetReal("竖曲线半径：")
'Ratio = ThisDrawing.Utility.GetReal("放大倍数：")
Ratio = 100
Dim Pt1(0 To 1) As Double
Dim Pt2(0 To 1) As Double
Dim Pt3(0 To 1) As Double
Dim Pt4(0 To 1) As Double
Dim intPt(0 To 1) As Double
Dim TanPt0(0 To 1) As Double
Dim TanPt1(0 To 1) As Double
Dim cenPt(0 To 2) As Double

'求实际设计线的坐标
    Pt1(0) = pickLine1.StartPoint(0)
    Pt1(1) = pickLine1.StartPoint(1) / Ratio

    Pt2(0) = pickLine1.EndPoint(0)
    Pt2(1) = pickLine1.EndPoint(1) / Ratio
    
    Pt3(0) = pickLine2.StartPoint(0)
    Pt3(1) = pickLine2.StartPoint(1) / Ratio

    Pt4(0) = pickLine2.EndPoint(0)
    Pt4(1) = pickLine2.EndPoint(1) / Ratio


Dim JiaoDu(0 To 1) As Double, JiaJiao As Double


Select Case Sgn(Pt2(0) - Pt1(0))
    Case 0
      JiaoDu(0) = PI / 2 * Sgn(Pt2(1) - Pt1(1))
    Case 1
      JiaoDu(0) = Atn((Pt2(1) - Pt1(1)) / (Pt2(0) - Pt1(0)))
    Case -1
      JiaoDu(0) = Atn((Pt2(1) - Pt1(1)) / (Pt2(0) - Pt1(0))) + PI
End Select

Select Case Sgn(Pt4(0) - Pt3(0))
    Case 0
      JiaoDu(1) = PI / 2 * Sgn(Pt4(1) - Pt3(1))
    Case 1
      JiaoDu(1) = Atn((Pt4(1) - Pt3(1)) / (Pt4(0) - Pt3(0)))
    Case -1
      JiaoDu(1) = Atn((Pt4(1) - Pt3(1)) / (Pt4(0) - Pt3(0))) + PI
End Select

Dim L0 As Double, L1 As Double, T As Double
L0 = (Pt1(0) - Pt4(0)) * Sin(JiaoDu(1)) - (Pt1(1) - Pt4(1)) * Cos(JiaoDu(1))
L0 = L0 / (Sin(JiaoDu(0)) * Cos(JiaoDu(1)) - Sin(JiaoDu(1)) * Cos(JiaoDu(0)))

L1 = (Pt1(0) - Pt4(0)) * Sin(JiaoDu(0)) - (Pt1(1) - Pt4(1)) * Cos(JiaoDu(0))
L1 = L1 / (Sin(JiaoDu(1)) * Cos(JiaoDu(0)) - Sin(JiaoDu(0)) * Cos(JiaoDu(1)))

intPt(0) = Pt1(0) + L0 * Cos(JiaoDu(0))
intPt(1) = Pt1(1) + L0 * Sin(JiaoDu(0))
JiaoDu(0) = IIf(Sgn(intPt(0) - pickPnt0(0)) * Sgn(Pt2(0) - Pt1(0)) = 1, _
    JiaoDu(0), JiaoDu(0) - PI)
JiaoDu(1) = IIf(Sgn(intPt(0) - pickPnt1(0)) * Sgn(Pt4(0) - Pt3(0)) = -1, _
    JiaoDu(1), JiaoDu(1) - PI)

JiaJiao = JiaoDu(1) - JiaoDu(0)
       

T = ShuQuXianR * Tan(JiaJiao / 2)
T = Abs(T)

'切点坐标
TanPt0(0) = intPt(0) - T * Cos(JiaoDu(0))
TanPt0(1) = intPt(1) - T * Sin(JiaoDu(0))
TanPt0(1) = TanPt0(1) * Ratio
TanPt1(0) = intPt(0) + T * Cos(JiaoDu(1))
TanPt1(1) = intPt(1) + T * Sin(JiaoDu(1))
TanPt1(1) = TanPt1(1) * Ratio

'椭圆心坐标

cenPt(0) = TanPt0(0) + Cos(Sgn(Sin(JiaJiao)) * PI / 2 + JiaoDu(0)) * ShuQuXianR
cenPt(1) = TanPt0(1) + Sin(Sgn(Sin(JiaJiao)) * PI / 2 + JiaoDu(0)) * ShuQuXianR * Ratio
cenPt(2) = 0#

Dim majAxis(0 To 2) As Double
majAxis(0) = IIf(Ratio > 1, 0, ShuQuXianR)
majAxis(1) = IIf(Ratio > 1, ShuQuXianR * Ratio, 0)
majAxis(2) = 0#
'生成椭圆
Dim EnEllipse As AcadEllipse
Set EnEllipse = ThisDrawing.ModelSpace.AddEllipse(cenPt, majAxis, _
       IIf(Ratio > 1, 1 / Ratio, Ratio))

EnEllipse.StartParameter = JiaoDu(1)
EnEllipse.EndParameter = JiaoDu(0)
Dim ShuQuXianL As Double
JiaJiao = Abs(JiaJiao)
JiaJiao = IIf(JiaJiao > PI, JiaJiao - PI, JiaJiao)
ShuQuXianL = ShuQuXianR * JiaJiao
MsgBox ("竖曲线长：" & CStr(ShuQuXianL))
End Sub