frmanalyse.frm

一个不错的数控源码是vb的

VERSION 5.00
Begin VB.Form frmAnalyse 
   AutoRedraw      =   -1  'True
   Caption         =   "分析待加工文件"
   ClientHeight    =   4245
   ClientLeft      =   60
   ClientTop       =   285
   ClientWidth     =   5910
   Icon            =   "frmAnalyse.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4245
   ScaleWidth      =   5910
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton cmdOK 
      Caption         =   "确 定"
      Height          =   375
      Left            =   4560
      TabIndex        =   2
      Top             =   3720
      Width           =   975
   End
   Begin VB.Frame Frame1 
      Caption         =   "分析信息"
      Height          =   3495
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   5655
      Begin VB.ListBox lstMsg 
         Height          =   3105
         IntegralHeight  =   0   'False
         Left            =   120
         TabIndex        =   1
         Top             =   240
         Width           =   5415
      End
   End
End
Attribute VB_Name = "frmAnalyse"
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                    '实体层号
    ENum 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  '保存每层图元缩小前后的第一个点的坐标
Private correctPoint() As CoordType

Dim AnalyseFlag As Boolean

Dim errMsg As String

Const ch1 = 1
Const ch2 = 2
Const ch3 = 3
Dim step As Long
Dim pos1 As Double
Dim pos2 As Double
Dim center1 As Double
Dim center2 As Double
Dim angle As Double

Private Sub cmdOK_Click()
    Unload frmAnalyse
End Sub

Public Function AnalyseDXFFile() As Long
    arrayCount = 0
    
    If readDXFFileToDXFFileArray = -1 Then
        lstMsg.AddItem ("分析失败。")
        lstMsg.AddItem (errMsg)
        AnalyseDXFFile = 0
        Exit Function
    End If
    
    If readDXFFileArrayToEntitySectionArray = -1 Then
        lstMsg.AddItem ("分析失败。")
        lstMsg.AddItem (errMsg)
        AnalyseDXFFile = 0
        Exit Function
    End If
    
    If readEntitySectionArrayToEntityArray = -1 Then
        lstMsg.AddItem ("分析失败。")
        lstMsg.AddItem (errMsg)
        AnalyseDXFFile = 0
        Exit Function
    End If
    
    If readEntityArrayToInstructionSquence = -1 Then
        lstMsg.AddItem ("分析失败。")
        lstMsg.AddItem (errMsg)
        AnalyseDXFFile = 0
        Exit Function
    End If
    
    If readInstructionSquenceToList = -1 Then
        lstMsg.AddItem ("分析失败。")
        lstMsg.AddItem (errMsg)
        AnalyseDXFFile = 0
        Exit Function
    End If
    
    lstMsg.AddItem ("分析成功。")
    lstMsg.AddItem ("请检查配置选项，确认后开始加工")
    
    AnalyseDXFFile = 1
End Function
'#############################################################################
'把DXF文件的内容读到DXF文件数组DXFFileArray中
Private Function readDXFFileToDXFFileArray() As Long
    
    Dim LineNumber As Long
    Dim code As String
    Dim str As String
    
    On Error GoTo rDFTDAEerrHandle

    Open frmMain.lblFilePath.Caption 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
    
    readDXFFileToDXFFileArray = 0
    Exit Function
rDFTDAEerrHandle:
    errMsg = "请检查该文件是否存在。"
    readDXFFileToDXFFileArray = -1
End Function
'#############################################################################
'把DXF文件数组DXFFileArray中的实体段读到实体段数组EntitySectionArray中
Private Function readDXFFileArrayToEntitySectionArray() As Long
    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()       '以便检查段尾
        
    readDXFFileArrayToEntitySectionArray = 0
End Function
'#############################################################################
'把实体段数组EntitySectionArray读到实体类型结构数组entityarray中
Private Function readEntitySectionArrayToEntityArray() As Long
    
    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"
    
    On Error GoTo rESATEerrHandle
    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
                    codes = readTwoLines(EntitySectionArray())
            End Select
            
        End If
    Wend
    readEntitySectionArrayToEntityArray = 0
    Exit Function
rESATEerrHandle:
    errMsg = "文件中有未知图元，或图形有错误"
    readEntitySectionArrayToEntityArray = -1
End Function
'#############################################################################
'由层决定处理文件中各个实体的次序
Private Function readEntityArrayToInstructionSquence() As Long
    
    Dim cutTimes As Long
    Dim i As Long
    Dim j As Long
    Dim maxDepth As Double
    
        
    For i = LBound(EntityArray) To UBound(EntityArray)
        For j = i + 1 To UBound(EntityArray)
            If EntityArray(j).ELayer <> 0 And EntityArray(j).ELayer = EntityArray(i).ELayer Then
                lstMsg.AddItem ("有相同的非零图层号 " & EntityArray(i).ELayer & " " & EntityArray(i).EName & ",请检查图纸")
                readEntityArrayToInstructionSquence = -1
                Exit Function
            End If
        Next j
    Next i

    
    ReDim correctPoint(UBound(EntityArray)) As CoordType
    
    If cutterWidth = 0 Then
        errMsg = "请设置刀宽。"
        readEntityArrayToInstructionSquence = -1
        Exit Function
    End If
    
    For i = LBound(EntityArray) To UBound(EntityArray)
        EntityArray(i).ENum = i
    Next i
        
    If cutTwoTimes = 0 Then
        cutTimes = 0
    Else
        cutTimes = 1