📄 水泥混凝土路面结构设计.frm
字号:
Height = 255
Left = 240
TabIndex = 9
Top = 2040
Width = 1215
End
Begin VB.Label Label5
Caption = "路肩宽"
Height = 255
Left = 5400
TabIndex = 8
Top = 1440
Width = 1215
End
Begin VB.Label Label4
Caption = "道宽"
Height = 255
Left = 240
TabIndex = 7
Top = 1440
Width = 1215
End
Begin VB.Label Label3
Caption = "比例尺"
Height = 255
Left = 5400
TabIndex = 6
Top = 840
Width = 1215
End
Begin VB.Label Label1
Caption = "设计图名"
Height = 255
Left = 240
TabIndex = 5
Top = 840
Width = 1215
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'--------------------------
'Option Explicit
' 在运行程序之前，选择“Project/References”菜单，引用“AutoCAD 2002 Type Library”
Dim AcadApp As AcadApplication '在窗体代码声明段定义AcadApp
Dim AcadDoc As AcadDocument ' 文档对象作为窗体的全局对象
Dim connConnection As ADODB.Connection
Dim rsRecordset As ADODB.Recordset
Dim mblnAddMode As Boolean
Dim Layer() As Single
Private Sub Combo1_Change()
' Adodc2.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Documents and Settings\Administrator\桌面\me\db1.mdb;Persist Security Info=False"
' Adodc2.RecordSource = "select * from basic"
' Adodc2.Refresh
' Combo1.Text = Adodc2.Recordset.Fields("SJTM").Value
' Text1.Text = Adodc2.Recordset.Fields("BLC").Value
End Sub
'建立新文件
Private Sub Command1_Click()
On Error Resume Next
Set AcadApp = GetObject(, "AutoCAD.Application.17")
If Err Then
Err.Clear
Set AcadApp = CreateObject("AutoCAD.Application.17")
If Err Then
MsgBox ("不能运行AutoCAD2007,请检查是否安装了AutoCAD2007")
Exit Sub
End If
End If
AcadApp.Visible = True
AcadApp.WindowState = acMax
AcadApp.Documents.Add
End Sub
Private Sub Command2_Click()
Dim MyfileName As String
MyfileName = "C:\Documents and Settings\Administrator\桌面\城市道路路面结构图.dwg"
If Dir(MyfileName) <> "" Then
AcadApp.Documents.Open MyfileName
Else
MsgBox ("文件" + MyfileName + "不存在")
End If
End Sub
'保存当前文件
Private Sub Command3_Click()
' If Not AcadApp.ActiveDocument.Saved Then
' If MsgBox("是否保存文件？", vbYesNo) = vbYes Then
' AcadApp.ActiveDocument.Save
' End If
' Else
' MsgBox ("保存过")
' End If
AcadApp.ActiveDocument.Save
End Sub
'退出CAD
Private Sub Command4_Click()
AcadApp.Quit
Set AcadApp = Nothing
End Sub
'生成图形
Private Sub Command5_Click()
'画最上面线
Dim lineobj11 As AcadLine
Dim lineobj12 As AcadLine
Dim lineobj13 As AcadLine
Dim lineobj14 As AcadLine
Dim Point11(0 To 2) As Double
Dim Point12(0 To 2) As Double
Dim Point13(0 To 2) As Double
Dim Point14(0 To 2) As Double
Dim Point15(0 To 2) As Double
Dim X0 As Double
Dim Y0 As Double
Dim dk As Double
Dim ljk As Double
Dim cdpd As Double
Dim ljpd As Double
dk = Me.Text3.Text
ljk = Me.Text4.Text
cdpd = Me.Text6.Text
ljpd = Me.Text7.Text
X0 = 10000: Y0 = 10000
Point11(0) = X0 - 1000 * ljk: Point11(1) = Y0 - 1000 * ljk * ljpd / 100: Point11(2) = 0#
Point12(0) = X0: Point12(1) = Y0: Point12(2) = 0#
Point13(0) = X0 + 1000 * dk: Point13(1) = Y0 + 1000 * dk * cdpd / 100: Point13(2) = 0#
Point14(0) = X0 + 2 * 1000 * dk: Point14(1) = Y0: Point14(2) = 0#
Point15(0) = X0 + 2 * 1000 * dk + 1000 * ljk: Point15(1) = Y0 - 1000 * ljk * ljpd / 100: Point15(2) = 0#
Set lineobj11 = AcadApp.ActiveDocument.ModelSpace.AddLine(Point11, Point12)
Set lineobj12 = AcadApp.ActiveDocument.ModelSpace.AddLine(Point12, Point13)
Set lineobj13 = AcadApp.ActiveDocument.ModelSpace.AddLine(Point13, Point14)
Set lineobj14 = AcadApp.ActiveDocument.ModelSpace.AddLine(Point14, Point15)
'画下面线（利用循环）
Dim proname As String
' ' 画下面线
' Dim lineobj11 As AcadLine
' Dim lineobj12 As AcadLine
' Dim startPoint1(0 To 2) As Double
' Dim midPoint1(0 To 2) As Double
' Dim endPoint1(0 To 2) As Double
' Dim n As Double 'n为路幅的一半
' Dim i As Double 'i为坡度
' Dim X0 As Double
' Dim Y0 As Double
' Dim X1 As Double
' Dim Y1 As Double
' Dim X2 As Double
' Dim Y2 As Double
' n = Me.Text1.Text
' i = Me.Text4.Text
' X0 = 50
' Y0 = 50
' X1 = X0 + n
' Y1 = Y0 + n * i / 100
' X2 = X1 + n
' Y2 = Y0
' '定义直线的起点与终点的三维坐标
' startPoint1(0) = X0#: startPoint1(1) = Y0#: startPoint1(2) = 0#
' midPoint1(0) = X1#: midPoint1(1) = Y1#: midPoint1(2) = 0#
' endPoint1(0) = X2#: endPoint1(1) = Y2#: endPoint1(2) = 0#
' '创建Line直线
' Set lineobj11 = AcadApp.ActiveDocument.ModelSpace.AddLine(startPoint1, midPoint1)
' Set lineobj12 = AcadApp.ActiveDocument.ModelSpace.AddLine(midPoint1, endPoint1)
'
' ' 画中间线
' Dim lineobj21 As AcadLine
' Dim lineobj22 As AcadLine
' Dim startPoint2(0 To 2) As Double
' Dim midPoint2(0 To 2) As Double
' Dim endPoint2(0 To 2) As Double
' Dim N1 As Double
' Dim X20 As Double
' Dim Y20 As Double
' Dim X21 As Double
' Dim Y21 As Double
' Dim X22 As Double
' Dim Y22 As Double
' N1 = Me.Text2.Text
' X20 = X0
' Y20 = Y0 + N1
' X21 = X1
' Y21 = Y1 + N1
' X22 = X2
' Y22 = Y2 + N1
' '定义直线的起点与终点的三维坐标
' startPoint2(0) = X20#: startPoint2(1) = Y20#: startPoint2(2) = 0#
' midPoint2(0) = X21#: midPoint2(1) = Y21#: midPoint2(2) = 0#
' endPoint2(0) = X22#: endPoint2(1) = Y22#: endPoint2(2) = 0#
' '创建Line直线
' Set lineobj21 = AcadApp.ActiveDocument.ModelSpace.AddLine(startPoint2, midPoint2)
' Set lineobj22 = AcadApp.ActiveDocument.ModelSpace.AddLine(midPoint2, endPoint2)
'
' ' 画上面线
' Dim lineobj31 As AcadLine
' Dim lineobj32 As AcadLine
' Dim startPoint3(0 To 2) As Double
' Dim midPoint3(0 To 2) As Double
' Dim endPoint3(0 To 2) As Double
' Dim N2 As Double
' Dim X30 As Double
' Dim Y30 As Double
' Dim X31 As Double
' Dim Y31 As Double
' Dim X32 As Double
' Dim Y32 As Double
' N2 = Me.Text3.Text
' X30 = X20
' Y30 = Y20 + N2
' X31 = X21
' Y31 = Y21 + N2
' X32 = X22
' Y32 = Y22 + N2
' '定义直线的起点与终点的三维坐标
' startPoint3(0) = X30#: startPoint3(1) = Y30#: startPoint3(2) = 0#
' midPoint3(0) = X31#: midPoint3(1) = Y31#: midPoint3(2) = 0#
' endPoint3(0) = X32#: endPoint3(1) = Y32#: endPoint3(2) = 0#
' '创建Line直线
' Set lineobj31 = AcadApp.ActiveDocument.ModelSpace.AddLine(startPoint3, midPoint3)
' Set lineobj32 = AcadApp.ActiveDocument.ModelSpace.AddLine(midPoint3, endPoint3)
'
'
' '创建两边的竖线
' Dim lineobjl1 As AcadLine
' Dim lineobjl2 As AcadLine
' Dim lineobjr1 As AcadLine
' Dim lineobjr2 As AcadLine
' Set lineobjl1 = AcadApp.ActiveDocument.ModelSpace.AddLine(startPoint1, startPoint2)
' Set lineobjl2 = AcadApp.ActiveDocument.ModelSpace.AddLine(startPoint2, startPoint3)
' Set lineobjr1 = AcadApp.ActiveDocument.ModelSpace.AddLine(endPoint1, endPoint2)
' Set lineobjr2 = AcadApp.ActiveDocument.ModelSpace.AddLine(endPoint2, endPoint3)
' '填充
' Dim hatchObj As AcadHatch
' Dim patternName As String
' Dim PatternType As Long
' Dim bAssociativity As Boolean
'
' PatternType = 0
' patternName = "ANSI31"
' bAssociativity = True
'
' Set hatchObj = AcadApp.ActiveDocument.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
'
' Dim outerLoop(0 To 0) As AcadEntity
'
' Dim plineObj As AcadLWPolyline
' Dim points(0 To 11) As Double
'
' points(0) = X0: points(1) = Y0
' points(2) = X1: points(3) = Y1
' points(4) = X2: points(5) = Y2
' points(6) = X22: points(7) = Y22
' points(8) = X21: points(9) = Y21
' points(10) = X20: points(11) = Y20
'
' Set plineObj = AcadApp.ActiveDocument.ModelSpace.AddLightWeightPolyline(points)
' plineObj.Closed = True
' Set outerLoop(0) = plineObj
'
' hatchObj.AppendOuterLoop (outerLoop)
' hatchObj.Evaluate
' outerLoop(0).Delete
'
' '添加文字
' Dim StyObj1 As AcadTextStyle
' Dim typeFace As String
' Dim Bold As Boolean
' Dim Italic As Boolean
' Dim charSet As Long
' Dim PitchandFamily As Long
' Set StyObj1 = AcadApp.ActiveDocument.TextStyles.Add _
' ("自己设置文本样式1")
' typeFace = "宋体"
' Italic = True
' Bold = True
' charSet = 1
' PitchandFamily = 1 Or 16
' StyObj1.SetFont typeFace, Bold, Italic, charSet, PitchandFamily
'
' Dim StyObj2 As AcadTextStyle
' Set StyObj2 = AcadApp.ActiveDocument.TextStyles.Add _
' ("自己设置文本样式2")
' StyObj2.fontFile = "C:\WINDOWS\Fonts\stcaiyun.ttf"
'
' Dim textObj As AcadText
' Dim textString As String
' Dim insertionPoint(0 To 2) As Double
' Dim height As Double
' textString = "AutoCAD二次开发."
' height = 0.3
' insertionPoint(0) = 18: insertionPoint(1) = 10: insertionPoint(2) = 0
'
' AcadApp.ActiveDocument.ActiveTextStyle = StyObj1
' Set textObj = AcadApp.ActiveDocument.ModelSpace.AddText _
' (textString, insertionPoint, height)
' textObj.Update
'
' insertionPoint(0) = 30: insertionPoint(1) = 10: insertionPoint(2) = 0
' AcadApp.ActiveDocument.ActiveTextStyle = StyObj2
' Set textObj = AcadApp.ActiveDocument.ModelSpace.AddText _
' (textString, insertionPoint, height)
' textObj.Update
'
' StyObj2.fontFile = "C:\WINDOWS\Fonts\stxingka.ttf"
' insertionPoint(0) = 40: insertionPoint(1) = 10: insertionPoint(2) = 0
' AcadApp.ActiveDocument.ActiveTextStyle = StyObj2
' Set textObj = AcadApp.ActiveDocument.ModelSpace.AddText _
' (textString, insertionPoint, height)
' textObj.Update
'
' '尺寸标注
' Dim dimObj As AcadDimAligned
' Dim location(0 To 2) As Double
' Dim xb As Double
' Dim yb As Double
' xb = (X2 - X0) / 2 + X0
' yb = Y1 + n * 0.2
' location(0) = xb: location(1) = yb: location(2) = 0#
'
' Set dimObj = AcadApp.ActiveDocument.ModelSpace.AddDimAligned _
' (startPoint1, endPoint1, location)
ZoomAll
End Sub
'保存数据库
Private Sub Command6_Click()
On Error Resume Next
Adodc2.Recordset.Fields("SJTM").Value = Combo1.Text
Adodc2.Recordset.Update
mblnAddMode = False
Command7.Enabled = True
Command6.Enabled = False
End Sub
Private Sub Command7_Click()
Command7.Enabled = False
Command6.Enabled = True
Combo1.Text = ""
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text5.Text = ""
Text6.Text = ""
Text7.Text = ""
mblnAddMode = True
Adodc2.Recordset.AddNew
End Sub
Private Sub Command8_Click()
n = dkGrid1.Rows
ReDim Layer(1 To n, 0 To 5) As Single
j = 1
End Sub
Private Sub Command9_Click()
dkGrid1.Rows = dkGrid1.Rows + 1
Combo1.AddItem "工程" + Str$(Int(10 * Rnd(1)))
End Sub
Private Sub Form_Load()
Dim strConnect As String
Dim a As Integer
Dim strProvider As String
Dim strDataSource As String
Dim strDataBaseName As String
strProvider = "Provider=Microsoft.Jet.OLEDB.4.0;"
strDataSource = App.Path
strDataBaseName = "\db1.mdb;"
strDataSource = "Data Source=" & strDataSource & strDataBaseName
strConnect = strProvider & strDataSource
Set connConnection = New ADODB.Connection
connConnection.CursorLocation = adUseClient
connConnection.Open strConnect
Set rsRecordset = New ADODB.Recordset
rsRecordset.CursorType = adOpenStatic
rsRecordset.CursorLocation = adUseClient
rsRecordset.LockType = adLockPessimistic
rsRecordset.Source = "SELECT * FROM layer"
rsRecordset.ActiveConnection = connConnection
rsRecordset.Open
Adodc1.ConnectionString = strConnect
Adodc1.RecordSource = "SELECT * FROM layer"
Adodc1.Refresh
DataGrid1.Refresh
Adodc2.Refresh
Combo1.Text = Adodc2.Recordset.Fields("SJTM").Value
Text1.Text = Adodc2.Recordset.Fields("BLC").Value
Text2.Text = Adodc2.Recordset.Fields("DK").Value
Text3.Text = Adodc2.Recordset.Fields("LJK").Value
Text4.Text = Adodc2.Recordset.Fields("CS").Value
Text5.Text = Adodc2.Recordset.Fields("CDPD").Value
Text6.Text = Adodc2.Recordset.Fields("LJPD").Value
Text7.Text = Adodc2.Recordset.Fields("LJBPPJ").Value
mblnAddMode = False
For i = 1 To 10
Call Command9_Click
Next i
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -