autocad2000.bas

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

Attribute VB_Name = "AutoCAD2000"

Option Explicit
Public Const PI = 3.14159265359
Public acadApp As Object
Public ThisDrawing As Object
Public objTextStyle As AcadTextStyle
Sub Main()
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application.15")
If Err <> 0 Then
    Err.Clear
    Set acadApp = CreateObject("AutoCad.Application")
    If Err Then
        MsgBox Err.Description
        Exit Sub
    End If
End If
Set ThisDrawing = acadApp.ActiveDocument
acadApp.Visible = True

'用Romane字型作为当前字型
Set objTextStyle = ThisDrawing.TextStyles.Add("romane")
objTextStyle.BigFontFile = "hztxt"
objTextStyle.fontFile = CurDir & "\fonts\romane.shx"
objTextStyle.Width = 0.8
ThisDrawing.ActiveTextStyle = objTextStyle
ZhiXianYuanHu
End Sub
'绘制标题

Public Sub DrawBiaoTi()
Dim objBlock As AcadBlock
Dim points() As Double
ReDim points(0 To 2) As Double
points(0) = 0: points(1) = 0: points(2) = 0
On Error Resume Next
Set objBlock = ThisDrawing.Blocks.Item("zdmBiaoTi")
If Err = 0 Then _
MsgBox "已经有名为zdmBiaoTi的块", vbExclamation _
: objBlock.Erase
Set objBlock = ThisDrawing.Blocks.Add(points, "zdmBiaoTi")
'****

Dim objPline As AcadLWPolyline

ReDim points(0 To 7) As Double
points(0) = 40: points(1) = 0
points(2) = 0: points(3) = 0
points(4) = 0: points(5) = 160
points(6) = 40: points(7) = 160
Set objPline = objBlock.AddLightWeightPolyline(points)
objPline.ConstantWidth = 0.7
'*********
Dim i As Integer
For i = 1 To 9
ReDim points(0 To 3) As Double
points(0) = Choose(i, 40, 0, 0, 0, 0, 0, 0, 20, 20)
points(1) = Choose(i, 0, 20, 44, 62, 80, 140, 120, 100, 80)
points(2) = Choose(i, 40, 40, 40, 40, 40, 40, 40, 40, 20)
 points(3) = Choose(i, 160, 20, 44, 62, 80, 140, 120, 100, 120)
Set objPline = objBlock.AddLightWeightPolyline(points)
Next i
'***********
'写文字
Dim objMtext As AcadMText
Dim txtStr As String
ReDim points(0 To 2) As Double
txtStr = "平 面 示 意"
points(0) = 0: points(1) = 13: points(2) = 0
Set objMtext = objBlock.AddMText(points, 40, txtStr)
objMtext.Height = 6
objMtext.AttachmentPoint = acAttachmentPointBottomCenter
'*******
txtStr = "里 程 桩 号"
points(0) = 0: points(1) = 35: points(2) = 0
Set objMtext = objBlock.AddMText(points, 40, txtStr)
objMtext.Height = 6
objMtext.AttachmentPoint = acAttachmentPointBottomCenter
'*******
txtStr = "设 计 标 高"
points(0) = 0: points(1) = 57: points(2) = 0
Set objMtext = objBlock.AddMText(points, 40, txtStr)
objMtext.Height = 6
objMtext.AttachmentPoint = acAttachmentPointBottomCenter
'*******
txtStr = "地 面 标 高"
points(0) = 0: points(1) = 75: points(2) = 0
Set objMtext = objBlock.AddMText(points, 40, txtStr)
objMtext.Height = 6
objMtext.AttachmentPoint = acAttachmentPointBottomCenter
'*******
txtStr = "坡度(%)/坡长"
points(0) = 0: points(1) = 133: points(2) = 0
Set objMtext = objBlock.AddMText(points, 40, txtStr)
objMtext.Height = 6
objMtext.AttachmentPoint = acAttachmentPointBottomCenter
'*******
txtStr = "竖  曲  线"
points(0) = 0: points(1) = 153: points(2) = 0
Set objMtext = objBlock.AddMText(points, 40, txtStr)
objMtext.Height = 6
objMtext.AttachmentPoint = acAttachmentPointBottomCenter
'*******
txtStr = "填 挖\P" & "高 度"
points(0) = 0: points(1) = 108: points(2) = 0
Set objMtext = objBlock.AddMText(points, 20, txtStr)
objMtext.Height = 6
objMtext.AttachmentPoint = acAttachmentPointBottomCenter
'*******
txtStr = "填\P" & "挖"
points(0) = 20: points(1) = 103: points(2) = 0
Set objMtext = objBlock.AddMText(points, 20, txtStr)
objMtext.Height = 6
objMtext.AttachmentPoint = acAttachmentPointBottomCenter
objMtext.LineSpacingFactor = 2
'*********
ReDim points(0 To 3) As Double
points(0) = 40: points(1) = 160
points(2) = 40: points(3) = 160 + (GcBcHigh - GcBcLow) * 1000 / ZxBl
Set objPline = objBlock.AddLightWeightPolyline(points)

For i = 1 To GcBcHigh - GcBcLow
ReDim points(0 To 3) As Double
points(0) = 40: points(1) = 160 + i * 1000 / ZxBl
points(2) = 43: points(3) = 160 + i * 1000 / ZxBl
Set objPline = objBlock.AddLightWeightPolyline(points)
'*******
ReDim points(0 To 2) As Double
txtStr = CStr(GcBcLow + i)
points(0) = 35: points(1) = 162 + i * 1000 / ZxBl: points(2) = 0
Set objMtext = objBlock.AddMText(points, 5, txtStr)
objMtext.Height = 4
objMtext.AttachmentPoint = acAttachmentPointBottomCenter
Next i
Dim objBlockRef As AcadBlockReference
ReDim points(0 To 2) As Double
points(0) = 0: points(1) = 0: points(2) = 0
Dim xScale As Double
xScale = CDbl(HxBl) / 1000
Set objBlockRef = ThisDrawing.ModelSpace.InsertBlock _
   (points, "zdmBiaoTi", xScale, xScale, xScale, 0#)
End Sub

Public Sub DrawKuang()
Dim objPline As AcadLWPolyline
Dim points() As Double
'*********
ReDim points(0 To 7) As Double
points(0) = 40 * CDbl(HxBl) / 1000
points(1) = 0
points(2) = points(0) + ZhuangHaoS(DmSzNums) - ZhuangHaoS(1)
points(3) = 0
points(4) = points(2)
points(5) = 160 * CDbl(HxBl) / 1000
points(6) = points(0)
points(7) = points(5)
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline _
    (points)
objPline.ConstantWidth = 0.7 * CDbl(HxBl) / 1000
'******
Dim i As Integer
For i = 1 To 7
ReDim points(0 To 3) As Double
points(0) = 40 * CDbl(HxBl) / 1000
points(1) = Choose(i, 20, 44, 62, 80, 100, 120, 140) _
  * CDbl(HxBl) / 1000
points(2) = points(0) + ZhuangHaoS(DmSzNums) - ZhuangHaoS(1)
points(3) = points(1)
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline _
    (points)
Next i
End Sub

Public Sub ZhuangHaoDraw(ZhuangHao As Single)
Dim objPline As AcadLWPolyline
Dim points() As Double
ReDim points(0 To 3) As Double
points(0) = 40 * CDbl(HxBl) / 1000# + ZhuangHao - ZhuangHaoS(1)
points(1) = 20 * CDbl(HxBl) / 1000#
points(2) = 40 * CDbl(HxBl) / 1000# + ZhuangHao - ZhuangHaoS(1)
points(3) = 120 * CDbl(HxBl) / 1000#
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline _
    (points)
'*********
'********
'写文字

Dim objMtext As AcadMText
Dim txtStr As String
ReDim points(0 To 2) As Double
Dim i As Integer
Dim TwH As Single
TwH = SjGc(ZhuangHao) - XzGc(ZhuangHao)
For i = 1 To 4
points(0) = IIf((Abs(ZhuangHao - ZhuangHaoS(1)) >= 1), _
40 * CDbl(HxBl) / 1000# - 12, 44 * CDbl(HxBl) / 1000 - 12) + _
    ZhuangHao - ZhuangHaoS(1)
points(1) = Choose(i, 36, 58, 76, IIf((Sgn(TwH) = -1), 94, 114)) _
  * CDbl(HxBl) / 1000
points(2) = 0
txtStr = Choose(i, _
  CZhuangHao(CStr(ZhuangHao)), _
  CBg(CStr(SjGc(ZhuangHao))), _
  CBg(CStr(XzGc(ZhuangHao))), _
  CBg(CStr((Abs(TwH)))))
Set objMtext = ThisDrawing.ModelSpace.AddMText(points, 24, txtStr)
objMtext.Height = 4 * CDbl(HxBl) / 1000#
objMtext.AttachmentPoint = acAttachmentPointBottomCenter
objMtext.Rotation = PI / 2
Next
End Sub

Public Sub DrawDiMian()
Dim points() As Double
ReDim points(0 To 2 * DmSzNums - 1) As Double
Dim i As Integer
For i = 1 To DmSzNums
points(2 * i - 2) = ZhuangHaoToZB(ZhuangHaoS(i))
points(2 * i - 1) = GcTOZB(DmBgS(i))
Next i
Dim objPline As AcadLWPolyline
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline _
    (points)

End Sub

Public Function GcTOZB(Gc As Single)
GcTOZB = 160 + 1000# / ZxBl * (Gc - GcBcLow)
GcTOZB = GcTOZB * CDbl(HxBl) / 1000#
End Function

Public Function ZhuangHaoToZB(ZhuangHao As Single)
ZhuangHaoToZB = 40 * CDbl(HxBl) / 1000#
ZhuangHaoToZB = ZhuangHaoToZB + ZhuangHao - ZhuangHaoS(1)
End Function

Public Sub DrawSheJiXian()
Dim objBlock As AcadBlock
Dim points() As Double
ReDim points(0 To 2) As Double
points(0) = SjZhS(1)
points(1) = SjBgS(1)
points(2) = 0
On Error Resume Next
Set objBlock = ThisDrawing.Blocks.Item("zdmSheJiXian")
If Err = 0 Then _
MsgBox "已经有名为zdmSheJiXian的块", vbExclamation _
: objBlock.Erase
Set objBlock = ThisDrawing.Blocks.Add(points, "zdmSheJiXian")

ReDim points(0 To 4 * SjNums - 5) As Double
points(0) = SjZhS(1): points(1) = SjBgS(1)
points(4 * SjNums - 6) = SjZhS(SjNums)
points(4 * SjNums - 5) = SjBgS(SjNums)
Dim i As Integer
For i = 2 To SjNums - 1
points(4 * i - 6) = SjZhS(i) - SjGcTs(i)
points(4 * i - 5) = SjGc(CSng(points(4 * i - 6)))
points(4 * i - 4) = SjZhS(i) + SjGcTs(i)
points(4 * i - 3) = SjGc(CSng(points(4 * i - 4)))
Next i
Dim objPline As AcadLWPolyline
Set objPline = objBlock.AddLightWeightPolyline _
    (points)
objPline.Color = acYellow
For i = 2 To SjNums - 1
objPline.SetBulge (2 * i - 3), SjGcBulge(i)
Next
objPline.Update

'Load DASHED线形
Dim objLinetype As AcadLineType
ThisDrawing.Linetypes.Load "DASHED", "acad.lin"
Set objLinetype = ThisDrawing.Linetypes.Add("DASHED")
For i = 2 To SjNums - 1
Dim j As Integer