📄 frmopen.frm
字号:
VERSION 5.00
Begin VB.Form frmOpen
BorderStyle = 1 'Fixed Single
Caption = "打开"
ClientHeight = 6810
ClientLeft = 2310
ClientTop = 750
ClientWidth = 7335
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6810
ScaleWidth = 7335
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton cmdCancle
Caption = "确定"
Height = 735
Left = 6720
TabIndex = 6
Top = 1080
Width = 375
End
Begin VB.CommandButton cmdOK
Caption = "打开"
Height = 735
Left = 6720
TabIndex = 5
Top = 360
Width = 375
End
Begin VB.Frame Frame2
Caption = "查找范围"
Height = 1935
Left = 120
TabIndex = 1
Top = 120
Width = 7095
Begin VB.FileListBox filFile
Height = 1530
Left = 3960
Pattern = "*.dxf"
TabIndex = 4
Top = 240
Width = 2535
End
Begin VB.DirListBox dirDir
Height = 1140
Left = 120
TabIndex = 3
Top = 600
Width = 3735
End
Begin VB.DriveListBox drvDrive
Height = 300
Left = 120
TabIndex = 2
Top = 240
Width = 3735
End
End
Begin VB.Frame Frame1
Caption = "图像预览"
Height = 4575
Left = 120
TabIndex = 0
Top = 2160
Width = 7095
Begin VB.Label lblImage
Alignment = 2 'Center
BeginProperty Font
Name = "宋体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 2280
TabIndex = 7
Top = 1920
Width = 2445
End
Begin VB.Image imgDXF
Height = 4215
Left = 120
Stretch = -1 'True
Top = 240
Width = 6780
End
End
End
Attribute VB_Name = "frmOpen"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Type CoordType '二维坐标型
CX As Double '第一坐标
CY As Double '第二坐标
End Type
Private Type EntityType '实体结构类型
EName As String '实体类别名称
EDepth As Double '实体厚度
ELayer As Long '实体层号
ECoord() As CoordType '实体中各点坐标
EConvex() As Double '弧的凸度,或半径
EPnum As Long '多线段中点的个数
End Type
Private Type LineType '直线类型
LK As Variant '斜率
LB As Double '截距
LBegin As CoordType '起始端点
LEnd As CoordType '末端点
End Type
Private Type ArcType '圆弧类型
ACentre As CoordType '圆弧的圆心
ABegin As CoordType '圆弧的起点坐标
AEnd As CoordType '圆弧的终点坐标
ARadius As Double '圆弧的半径
AAngle As Double '圆弧包含的角度(角度制),负值表示逆时针方向旋转
End Type
Dim DXFFileName As String
Dim DXFFileArray() As String
Dim EntitySectionArray() As String
Dim EntityArray() As EntityType
Private Type ScannerType '扫描器类型
SSquence() As CoordType '这一行扫描后得到的点序
SAvailab As Boolean '这一行是否扫空(有效)
SDepth As Double '扫描层的厚度
SLayer As Long '扫描层的层号
End Type
Private arrayCount As Long
Private arrayLines As Long
Private Last As CoordType '保存上一次运动末的点的坐标
Private firPoint(1) As CoordType '保存每层图元的第一个点的坐标
Dim cutWay As Long
Dim standHigh As Double
Dim cutterWidth As Double
Private Sub cmdCancle_Click()
Unload frmOpen
End Sub
Private Sub cmdOK_Click()
If filFile.filename = "" Then
MsgBox "请选择一个文件!"
Else
Call filFile_DblClick
End If
End Sub
Private Sub dirDir_Change()
filFile.Path = dirDir.Path
End Sub
Private Sub drvDrive_Change()
On Error GoTo errorhandler
dirDir.Path = drvDrive.Drive
Exit Sub
errorhandler:
Dim message As String
If Err.Number = 68 Then
Dim r As Integer
message = "Drive is not ready"
r = MsgBox(message, vbRetryCancel + vbCritical, "")
If r = vbRetry Then
Resume
Else
drvDrive.Drive = drvDrive.List(1)
Resume Next
End If
Else
Call MsgBox(Err.Description, vbOKOnly + vbExclamation)
Resume Next
End If
End Sub
Private Sub filFile_Click()
Dim DXFImage As String
DXFImage = Replace(filFile.filename, ".dxf", ".bmp")
On Error GoTo errhand1
Open DXFImage For Input As #2
Close #2
lblImage.Visible = False
imgDXF.Picture = LoadPicture(DXFImage)
errhand1:
If Err Then
imgDXF.Picture = LoadPicture()
lblImage.Visible = True
lblImage.Caption = "没有预览图形"
End If
End Sub
Private Sub filFile_DblClick()
DXFFileName = filFile.Path & "\" & filFile.filename
readDXFFileToDXFFileArray
readDXFFileArrayToEntitySectionArray
readEntitySectionArrayToentityarray
readentityarrayToInstructionSquence
'Unload frmOpen
End Sub
'#############################################################################
'把DXF文件的内容读到DXF文件数组DXFFileArray中
Private Sub readDXFFileToDXFFileArray()
Dim LineNumber As Integer
Dim Code As String
Dim str As String
Open DXFFileName For Input As #1
LineNumber = 0
While Code <> "EOF" And Not EOF(1)
Line Input #1, str
Code = Trim(str)
ReDim Preserve DXFFileArray(LineNumber)
DXFFileArray(LineNumber) = Code
LineNumber = LineNumber + 1
Wend
Close 1
End Sub
'#############################################################################
'把DXF文件数组DXFFileArray中的实体段读到实体段数组EntitySectionArray中
Private Sub readDXFFileArrayToEntitySectionArray()
Dim lastObj As String
arrayCount = 0
arrayLines = 0
Dim codes As Variant
codes = readTwoLines(DXFFileArray())
While codes(1) <> "EOF"
If codes(0) = "0" And codes(1) = "SECTION" Then
codes = readTwoLines(DXFFileArray())
If codes(1) = "ENTITIES" Then
codes = readTwoLines(DXFFileArray())
While codes(1) <> "ENDSEC"
If codes(0) = "0" Then
lastObj = codes(1)
addToArray codes(0) & "", EntitySectionArray()
addToArray lastObj, EntitySectionArray()
End If
If codes(0) <> "0" Then
addToArray codes(0) & "", EntitySectionArray()
addToArray codes(1) & "", EntitySectionArray()
End If
codes = readTwoLines(DXFFileArray())
Wend
End If
Else
codes = readTwoLines(DXFFileArray())
End If
Wend
addToArray "0", EntitySectionArray() '添加一组码
addToArray "ENDS", EntitySectionArray() '以便检查段尾
End Sub
'#############################################################################
'把实体段数组EntitySectionArray读到实体类型结构数组entityarray中
Private Sub readEntitySectionArrayToentityarray()
arrayCount = 0
arrayLines = 0
Dim i As Long
Dim j As Long
Dim ecount As Long
Dim codes As Variant
Dim entityNameString As String
entityNameString = "POINT,LINE,CIRCLE,LWPOLYLINE"
codes = readTwoLines(EntitySectionArray())
While codes(1) <> "ENDS"
If InStr(entityNameString, codes(1)) Then
Select Case codes(1)
Case "CIRCLE"
ReDim Preserve EntityArray(ecount)
ReDim Preserve EntityArray(ecount).ECoord(0)
ReDim Preserve EntityArray(ecount).EConvex(0)
EntityArray(ecount).EName = codes(1)
codes = readTwoLines(EntitySectionArray())
While codes(0) <> "0"
Select Case codes(0)
Case "8": EntityArray(ecount).ELayer = codes(1) 'layer
Case "39": EntityArray(ecount).EDepth = codes(1) 'depth
Case "10": EntityArray(ecount).ECoord(0).CX = codes(1) 'x
Case "20": EntityArray(ecount).ECoord(0).CY = codes(1) 'y
Case "40": EntityArray(ecount).EConvex(0) = codes(1) 'radius
End Select
codes = readTwoLines(EntitySectionArray())
Wend
ecount = ecount + 1
Case "POINT"
ReDim Preserve EntityArray(ecount)
ReDim Preserve EntityArray(ecount).ECoord(0)
EntityArray(ecount).EName = codes(1)
codes = readTwoLines(EntitySectionArray())
While codes(0) <> "0"
Select Case codes(0)
Case "8": EntityArray(ecount).ELayer = codes(1) 'layer
Case "39": EntityArray(ecount).EDepth = codes(1) 'depth
Case "10": EntityArray(ecount).ECoord(0).CX = codes(1) 'x
Case "20": EntityArray(ecount).ECoord(0).CY = codes(1) 'y
End Select
codes = readTwoLines(EntitySectionArray())
Wend
ecount = ecount + 1
Case "LINE"
ReDim Preserve EntityArray(ecount)
ReDim Preserve EntityArray(ecount).ECoord(1)
EntityArray(ecount).EName = codes(1)
codes = readTwoLines(EntitySectionArray())
While codes(0) <> "0"
Select Case codes(0)
Case "8": EntityArray(ecount).ELayer = codes(1) 'layer
Case "39": EntityArray(ecount).EDepth = codes(1) 'depth
Case "10": EntityArray(ecount).ECoord(0).CX = codes(1) 'x1
Case "20": EntityArray(ecount).ECoord(0).CY = codes(1) 'x2
Case "11": EntityArray(ecount).ECoord(1).CX = codes(1) 'x2
Case "21": EntityArray(ecount).ECoord(1).CY = codes(1) 'y2
End Select
codes = readTwoLines(EntitySectionArray())
Wend
ecount = ecount + 1
Case "LWPOLYLINE"
ReDim Preserve EntityArray(ecount)
i = 0
EntityArray(ecount).EName = codes(1)
codes = readTwoLines(EntitySectionArray())
While codes(0) <> "0"
Select Case codes(0)
Case "8": EntityArray(ecount).ELayer = codes(1) 'layer
Case "90"
ReDim EntityArray(ecount).ECoord(codes(1) - 1)
ReDim EntityArray(ecount).EConvex(codes(1) - 1)
EntityArray(ecount).EPnum = codes(1)
Case "39": EntityArray(ecount).EDepth = codes(1) 'depth
Case "10"
EntityArray(ecount).ECoord(i).CX = codes(1)
Case "20"
EntityArray(ecount).ECoord(i).CY = codes(1)
i = i + 1
If (EntityArray(ecount).ECoord(i - 1).CX = EntityArray(ecount).ECoord(0).CX) _
And (i <> 1) And (EntityArray(ecount).ECoord(i - 1).CY = EntityArray(ecount).ECoord(0).CY) Then
EntityArray(ecount).EPnum = EntityArray(ecount).EPnum - 1
ReDim Preserve EntityArray(ecount).ECoord(EntityArray(ecount).EPnum - 1)
ReDim Preserve EntityArray(ecount).EConvex(EntityArray(ecount).EPnum - 1)
End If
Case "42"
If i <> UBound(EntityArray(ecount).EConvex) + 2 Then
EntityArray(ecount).EConvex(i - 1) = codes(1)
End If
End Select
codes = readTwoLines(EntitySectionArray())
Wend
ecount = ecount + 1
Case Else
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -