📄 form1.frm
字号:
VERSION 5.00
Object = "{67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0"; "MSADODC.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1
Caption = "CAD"
ClientHeight = 3570
ClientLeft = 60
ClientTop = 450
ClientWidth = 4770
LinkTopic = "Form1"
ScaleHeight = 3570
ScaleWidth = 4770
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton Command5
Caption = "分层"
Height = 375
Left = 2400
TabIndex = 10
Top = 3000
Width = 1215
End
Begin VB.CommandButton Command4
Caption = "打开文件"
Height = 375
Left = 2400
TabIndex = 4
Top = 2400
Width = 1215
End
Begin VB.TextBox zpian
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 420
Left = 2640
TabIndex = 2
Top = 1680
Width = 1095
End
Begin VB.TextBox zshu
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 420
Left = 2640
TabIndex = 1
Top = 1020
Width = 1095
End
Begin VB.CommandButton Command3
Caption = "建立坐标"
Height = 375
Left = 720
TabIndex = 3
Top = 2400
Width = 1215
End
Begin VB.TextBox pyi
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 420
Left = 2640
TabIndex = 0
Top = 360
Width = 1095
End
Begin VB.CommandButton Command2
Caption = "退出"
Height = 615
Left = 3960
TabIndex = 7
Top = 2520
Width = 735
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 240
Top = 120
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton Command1
Caption = "画线"
Height = 375
Left = 720
TabIndex = 5
Top = 3000
Width = 1215
End
Begin MSAdodcLib.Adodc Adodc1
Height = 495
Left = 2400
Top = 0
Visible = 0 'False
Width = 1335
_ExtentX = 2355
_ExtentY = 873
ConnectMode = 0
CursorLocation = 3
IsolationLevel = -1
ConnectionTimeout= 15
CommandTimeout = 30
CursorType = 3
LockType = 3
CommandType = 8
CursorOptions = 0
CacheSize = 50
MaxRecords = 0
BOFAction = 0
EOFAction = 0
ConnectStringType= 1
Appearance = 1
BackColor = -2147483643
ForeColor = -2147483640
Orientation = 0
Enabled = -1
Connect = ""
OLEDBString = ""
OLEDBFile = ""
DataSourceName = ""
OtherAttributes = ""
UserName = ""
Password = ""
RecordSource = ""
Caption = "Adodc1"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_Version = 393216
End
Begin VB.Label Label3
Caption = "坐标偏移"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 840
TabIndex = 9
Top = 1680
Width = 1215
End
Begin VB.Label Label2
Caption = "坐标数量"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 840
TabIndex = 8
Top = 1080
Width = 1095
End
Begin VB.Label Label1
Caption = "X偏移值"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 840
TabIndex = 6
Top = 480
Width = 975
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Command1_Click() '画线
Dim ucs As AcadUCS
Dim origin(0 To 2) As Double
Dim xa(0 To 2) As Double
Dim ya(0 To 2) As Double
'AutoCAD.Application.Documents(0).LoadShapeFile
'Dim i As Integer
'Dim myline As AcadLWPolyline
Dim vert(0 To 3999) As Double
Dim vert1(0 To 3999) As Double
'Dim pointh(0 To 2001) As Double
'Dim point1(0 To 2001) As Double
'Dim point2(0 To 2001) As Double
'Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim i As Integer
Dim j As Integer
If openfilename = "" Then
GoTo qu
End If
Set xlapp = CreateObject("Excel.Application")
Set xlBook = xlapp.Workbooks.Open(openfilename)
Set xlSheet = xlBook.Worksheets(1) '引用第1张工作表
pianyi = Val(pyi.Text) * (-1)
For i = 0 To 3999
'If xlapp.EOF <> True Then
'pointh(i) = xlApp.Cells(i + 3, 1)
'point1(i) = xlApp.Cells(i + 3, 2)
'point2(i) = xlApp.Cells(i + 3, 3)
vert(i) = xlapp.Cells(i + 3, 2) + pianyi: vert(i + 1) = xlapp.Cells(i + 3, 1) * (-1)
vert1(i) = xlapp.Cells(i + 3, 3) + pianyi: vert1(i + 1) = xlapp.Cells(i + 3, 1)
i = i + 1
'End If
Next i
Dim myline As AcadLWPolyline
Set myline = AutoCAD.Application.Application.Documents(0).ModelSpace.AddLightWeightPolyline(vert)
Set myline = AutoCAD.Application.Application.Documents(0).ModelSpace.AddLightWeightPolyline(vert1)
'Set myline = AutoCAD.Application.Application.Documents(0).ModelSpace.AddLightWeightPolyline(vert)
'lspoint(i) = spoint(i)
'lepoint(i) = epoint(i)
'Set myline = AutoCAD.Application.Documents(0).ModelSpace.AddLine(lspoint, lepoint)
origin(0) = 0#: origin(1) = 0#: origin(2) = 0#
xa(0) = 1#: xa(1) = 0#: xa(2) = 0#
ya(0) = 0#: ya(1) = -1#: ya(2) = 0#
Set ucs = AutoCAD.Application.Documents(0).UserCoordinateSystems.Add(origin, xa, ya, "test")
AutoCAD.Application.Documents(0).ActiveUCS = ucs
Dim ucsmat As Variant
ucsmat = ucs.GetUCSMatrix
i = AutoCAD.Application.Documents(0).ModelSpace.Count - 1
AutoCAD.Application.Documents(0).ModelSpace(i).TransformBy (ucsmat)
ZoomExtents
qu: End Sub
Private Sub Command2_Click()
Set xlapp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Set ucs = Nothing
End
End Sub
Private Sub Command3_Click() '画坐标
Dim ucs As AcadUCS
Dim origin(0 To 2) As Double
Dim xa(0 To 2) As Double
Dim ya(0 To 2) As Double
Dim k As Integer
Dim i As Integer
Dim j As Integer
Dim epoint(0 To 2) As Double
Dim epoint1(0 To 2) As Double
Dim spoint(0 To 2) As Double
Dim spoint1(0 To 2) As Double
spoint(0) = 0: spoint(1) = 0: spoint(2) = 0
epoint(0) = 0: epoint(1) = 2500: epoint(2) = 0
spoint1(0) = 0: spoint1(1) = 0: spoint1(2) = 0
epoint1(0) = 20: epoint1(1) = 0: epoint1(2) = 0
Dim myline As AcadLine
j = Val(zshu.Text) - 1
zuop = Val(zpian.Text)
For i = 0 To j
Set myline = AutoCAD.Application.Documents(0).ModelSpace.AddLine(spoint, epoint)
epoint(0) = epoint(0) + zuop
spoint(0) = spoint(0) + zuop
For k = 0 To 100
Set myline = AutoCAD.Application.Documents(0).ModelSpace.AddLine(spoint1, epoint1)
spoint1(1) = spoint1(1) + 25
epoint1(1) = epoint1(1) + 25
Next k
spoint1(0) = spoint1(0) + zuop
epoint1(0) = epoint1(0) + zuop
spoint1(1) = 0
epoint1(1) = 0
Next i
origin(0) = 0#: origin(1) = 0#: origin(2) = 0#
xa(0) = 1#: xa(1) = 0#: xa(2) = 0#
ya(0) = 0#: ya(1) = -1#: ya(2) = 0#
Set ucs = AutoCAD.Application.Documents(0).UserCoordinateSystems.Add(origin, xa, ya, "test")
AutoCAD.Application.Documents(0).ActiveUCS = ucs
Dim ucsmat As Variant
ucsmat = ucs.GetUCSMatrix
Dim ii As Integer
For i = 0 To AutoCAD.Application.Documents(0).ModelSpace.Count - 1
'ii = AutoCAD.Application.Documents(0).ModelSpace.Count - 1
AutoCAD.Application.Documents(0).ModelSpace(i).TransformBy (ucsmat)
Next i
ZoomExtents
End Sub
Private Sub Command4_Click()
CommonDialog1.DialogTitle = "打开文件"
CommonDialog1.Filter = "所有格式" + "(*.xls)"
CommonDialog1.ShowOpen
If CommonDialog1.FileName <> "" Then
If Err <> 32855 Then
openfilename = CommonDialog1.FileName
'Picture1.Picture = LoadPicture(openfilename)
End If
Else
End If
End Sub
Private Sub Command5_Click()
Dim ucs As AcadUCS
Dim origin(0 To 2) As Double
Dim xa(0 To 2) As Double
Dim ya(0 To 2) As Double
'AutoCAD.Application.Documents(0).LoadShapeFile
'Dim i As Integer
'Dim myline As AcadLWPolyline
Dim vert(0 To 3999) As Double
Dim vert1(0 To 3999) As Double
'Dim pointh(0 To 2001) As Double
'Dim point1(0 To 2001) As Double
'Dim point2(0 To 2001) As Double
'Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim i As Integer
Dim j As Integer
If openfilename = "" Then
GoTo qu
End If
Set xlapp = CreateObject("Excel.Application")
Set xlBook = xlapp.Workbooks.Open(openfilename)
Set xlSheet = xlBook.Worksheets(1) '引用第1张工作表
pianyi = Val(pyi.Text) * (-1)
For i = 0 To 3999
'If xlapp.EOF <> True Then
'pointh(i) = xlApp.Cells(i + 3, 1)
'point1(i) = xlApp.Cells(i + 3, 2)
'point2(i) = xlApp.Cells(i + 3, 3)
vert(i) = xlapp.Cells(i + 3, 2) + pianyi: vert(i + 1) = xlapp.Cells(i + 3, 1) * (-1)
vert1(i) = xlapp.Cells(i + 3, 3) + pianyi: vert1(i + 1) = xlapp.Cells(i + 3, 1)
i = i + 1
'End If
Next i
Dim myline As AcadLWPolyline
Set myline = AutoCAD.Application.Application.Documents(0).ModelSpace.AddLightWeightPolyline(vert)
Set myline = AutoCAD.Application.Application.Documents(0).ModelSpace.AddLightWeightPolyline(vert1)
'Set myline = AutoCAD.Application.Application.Documents(0).ModelSpace.AddLightWeightPolyline(vert)
'lspoint(i) = spoint(i)
'lepoint(i) = epoint(i)
'Set myline = AutoCAD.Application.Documents(0).ModelSpace.AddLine(lspoint, lepoint)
origin(0) = 0#: origin(1) = 0#: origin(2) = 0#
xa(0) = 1#: xa(1) = 0#: xa(2) = 0#
ya(0) = 0#: ya(1) = -1#: ya(2) = 0#
Set ucs = AutoCAD.Application.Documents(0).UserCoordinateSystems.Add(origin, xa, ya, "test")
AutoCAD.Application.Documents(0).ActiveUCS = ucs
Dim ucsmat As Variant
ucsmat = ucs.GetUCSMatrix
i = AutoCAD.Application.Documents(0).ModelSpace.Count - 1
AutoCAD.Application.Documents(0).ModelSpace(i).TransformBy (ucsmat)
ZoomExtents
End Sub
Private Sub Form_Load()
'Dim startpoint(0 To 2) As Double
'Dim endpoint(0 To 2) As Double
'startpoint(0) = 0: startpoint(1) = 0: startpoint(2) = 0
'endpoint(0) = 100: endpoint(1) = 300: endpoint(2) = 0
'Dim myline As AcadLine
'Set myline = AutoCAD.Application.Documents(0).ModelSpace.AddLine(startpoint, endpoint)
'Dim spoint(0 To 2000, 0 To 2) As Double
'Dim epoint(0 To 2000, 0 To 2) As Double
'Dim lspoint(0 To 2000) As Variant
'Dim lepoint(0 To 2000) As Variant
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -