frmanalyse.frm

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

    End If
    
    For i = 0 To cutTimes
        process i
    Next i
       
    returnOrigin
        
    readEntityArrayToInstructionSquence = 0
End Function
'#################################################
'读指令序列到分析窗体列表
Private Function readInstructionSquenceToList() As Long
    Dim i As Long
        
    Last.CX = 0
    Last.CY = 0
    
    On Error GoTo rISTLerrHandle
    lstMsg.Clear
    lstMsg.AddItem ("********************************************************")
    lstMsg.AddItem ("分析得到的指令序列")
    
    For i = 0 To UBound(instructionSquence)
        lstMsg.AddItem (instructionSquence(i))
    Next i
    
    lstMsg.AddItem ("结束")
    lstMsg.AddItem ("********************************************************")
    
    readInstructionSquenceToList = 0
    Exit Function
rISTLerrHandle:
    lstMsg.AddItem ("指令序列为空")
    readInstructionSquenceToList = -1
End Function
Private Sub process(Times As Long)
    Dim maxLayer As Long
    Dim layer As Long
    
    Dim TempDepth As Double
    
    Dim i As Long
    Dim j As Long
    Dim k As Long
    
    For i = LBound(EntityArray) To UBound(EntityArray)
        '寻找最大层号
        If EntityArray(i).ELayer >= maxLayer Then
            maxLayer = EntityArray(i).ELayer
        End If
    Next i
    
    '规定：
         '1.只有第零层只处理边缘
         '2.层号不为零的，按照层号的大小，从最大到最小处理
         '3.以层为单位处理图形表面,每层一般必须是一条闭合曲线
         
    For layer = maxLayer To 0 Step -1
        
        For j = LBound(EntityArray) To UBound(EntityArray)
                
            '处理实体的边缘
            
            If (EntityArray(j).ELayer = layer And layer = 0) _
                    Or (EntityArray(j).ELayer = layer And layer <> 0 And Times = 0) Then
  
                    
                If Times = 0 Then
                    firPoint(0) = EntityArray(j).ECoord(0)
                    
                    shrink EntityArray(j), cutterWidth / 2#
                    
                    firPoint(1) = EntityArray(j).ECoord(0)
                  
                    correctPoint(j) = Correct()
                    
                End If
                
                If cutTwoTimes = 1 And layer = 0 Then      '对0号图层进行两次切透
                    If Times = 0 Then
                        EntityArray(j).EDepth = EntityArray(j).EDepth / 2#
                    Else
                        EntityArray(j).EDepth = EntityArray(j).EDepth * 2#
                    End If
                End If
                    
                If layer = 0 And cutOneTime = 1 And Times = 0 Then
                    EntityArray(j).EDepth = EntityArray(j).EDepth + Buttom
                End If
                
                If layer = 0 And cutTwoTimes = 1 And Times = 1 Then
                    EntityArray(j).EDepth = EntityArray(j).EDepth + Buttom
                End If
                
                dealEdge EntityArray(j)
                                
                '按层号处理图形表面
                If layer <> 0 And Times = 0 Then
                    
                    TempDepth = EntityArray(j).EDepth
                                        
                    If swapOneTime = 1 Then
                        dealSurface EntityArray(j)
                    End If
                    
                    If swapTwoTimes = 1 Then
                        EntityArray(j).EDepth = TempDepth * SwapFactor(0)
                        dealSurface EntityArray(j)
                        EntityArray(j).EDepth = TempDepth
                        dealSurface EntityArray(j)
                    End If
                       
                    If swapThreeTimes = 1 Then
                        EntityArray(j).EDepth = TempDepth * SwapFactor(0)
                        dealSurface EntityArray(j)
                        
                        EntityArray(j).EDepth = TempDepth * SwapFactor(1)
                        dealSurface EntityArray(j)
                        
                        EntityArray(j).EDepth = TempDepth
                        dealSurface EntityArray(j)
                    End If
                End If
                    
            End If
            
        Next j
    
    Next layer
End Sub
'#############################################################################
'把一个实体theEntity向内缩小distance
Private Sub shrink(theEntity As EntityType, distance As Double)

    Select Case theEntity.EName
    
        '在这个过程中，只有圆和多线段的参数被改动
        '其它实体类型的缩小以适应轮廓无意义
        
        Case "CIRCLE":
            shrinkCircle theEntity, distance
        
        Case "LWPOLYLINE":
            shrinkLwpolyline theEntity, distance
            
    End Select
End Sub
'#############################################################################
'把一个实体theCircle向内缩小distance
Private Sub shrinkCircle(theCircle As EntityType, d As Double)

    '圆的参数只是半径减小了
    theCircle.EConvex(0) = theCircle.EConvex(0) - d
    
End Sub
'#############################################################################
'把一个实体theLwpolyline向内缩小distance
Private Sub shrinkLwpolyline(theLwpolyline As EntityType, d As Double)
    Dim i As Long
    
    Dim lineEquation As LineType
    Dim Line1 As LineType
    Dim Line2 As LineType
    
    Dim PointSquence() As CoordType
    
    Dim temp As Variant
    
    Dim dis As Double
    
    Dim elementsNum As Long               '多线段中点的个数
    elementsNum = theLwpolyline.EPnum
    
    ReDim PointSquence(elementsNum)
        
    For i = 0 To elementsNum - 1
            
        '假设实体为多边形,求出下点坐标
        PointSquence(i) = getNextPoint(theLwpolyline, i, d)
        
    Next i
        
    theLwpolyline = modifyPara(theLwpolyline, PointSquence(), d)
End Sub
        
Private Function getNextPoint(plnEty As EntityType, PNum As Long, d As Double) As CoordType
    Dim thisLine As LineType
    Dim Line1 As LineType
    Dim Line2 As LineType
    
    Dim pn As Long
    Dim angle_sep_line As LineType
    Dim thearc As ArcType
    
    Dim p1 As CoordType
    Dim p2 As CoordType
    Dim p3 As CoordType
    
    Dim pa As CoordType
    Dim pb As CoordType
    '                                            ^_^  -_-  *_*  @_@
    Dim checkLine As LineType
    Dim checkScanner As ScannerType
    Dim temp As Variant
    
    Dim i As Long
    Dim j As Long
        
    If plnEty.EPnum = 2 Then
            thisLine = getLine(plnEty.ECoord(0), plnEty.ECoord(1))
            temp = getNearLine(thisLine, d)
            Line1.LK = temp(0)
            Line1.LB = temp(1)
            Line2.LK = temp(2)
            Line2.LB = temp(3)
            thearc = getArc(plnEty, 0)
            temp = getLine_ArcIntersection(Line1, thearc)
            If temp(0) <> -1 Then
                getNextPoint = getNearPoint(temp, plnEty.ECoord(PNum))
                Exit Function
            End If
            temp = getLine_ArcIntersection(Line2, thearc)
            If temp(0) <> -1 Then
                getNextPoint = getNearPoint(temp, plnEty.ECoord(PNum))
                Exit Function
            End If
    End If
                
                
    If PNum = 7 Then
        PNum = 7
    End If
    
    
    
    
                
    p1 = plnEty.ECoord(PNum)
    If PNum = plnEty.EPnum - 1 Then
        p2 = plnEty.ECoord(0)
        p3 = plnEty.ECoord(1)
    Else
        If PNum = plnEty.EPnum - 2 Then
            p2 = plnEty.ECoord(PNum + 1)
            p3 = plnEty.ECoord(0)
        Else
            p2 = plnEty.ECoord(PNum + 1)
            p3 = plnEty.ECoord(PNum + 2)
        End If
    End If
    thisLine = getLine(p1, p2)
    temp = getNearLine(thisLine, d)
    Line1.LK = temp(0)
    Line1.LB = temp(1)
    Line2.LK = temp(2)
    Line2.LB = temp(3)
    
    angle_sep_line = get_angle_arv_sep_line(p1, p2, p3)
    
    pa = getLine_LineIntersection(Line1, angle_sep_line, 1)
    pb = getLine_LineIntersection(Line2, angle_sep_line, 1)
    
    checkLine.LK = 0
    checkLine.LB = pa.CY
    pn = 0
    checkScanner = scanLwpolyline(plnEty, checkLine, 1)
    If checkScanner.SAvailab = True Then
        For i = 0 To UBound(checkScanner.SSquence)
            If checkScanner.SSquence(i).CX > pa.CX Then
                pn = pn + 1
            End If
        Next i
    End If
    
    If pn Mod 2 = 1 Then
        getNextPoint = pa
    Else
        getNextPoint = pb
    End If
End Function
'#############################################################################
'求以p1, p2, p3 为顶点的三角形中p2 角的叫平分线
Private Function get_angle_arv_sep_line(p1 As CoordType, p2 As CoordType, p3 As CoordType) As LineType
    Dim angleA As Double
    Dim angle1 As Double
    Dim angle2 As Double
    
    angle1 = getAngle(p1, p2)
    angle2 = getAngle(p3, p2)
    
    angleA = (angle1 - angle2) / 2# + angle2
    
    get_angle_arv_sep_line.LK = Tan(angleA * 3.14159265358979 / 180#)
    
    get_angle_arv_sep_line.LB = p2.CY - get_angle_arv_sep_line.LK * p2.CX
End Function

Private Function point_on_line(p As CoordType, theLine As LineType) As Long
    Dim temp As Double
    
    If IsNull(theLine.LK) Then
        If p.CX = theLine.LB Then
            point_on_line = 1
        Else
            point_on_line = 0
        End If
    Else
        temp = theLine.LK * p.CX + theLine.LB
        If Abs(temp - p.CY) < 0.0001 Then
            point_on_line = 1
        Else
            point_on_line = 0
        End If
    End If
End Function
'#####################################
'修改缩小后实体的参数
Private Function modifyPara(plnEty As EntityType, PSquence() As CoordType, dis As Double) As EntityType
    
    Dim i As Long
    Dim j As Long
    Dim eleNum As Long         '多线段实体中点数组的上标
    eleNum = plnEty.EPnum
    
    Dim ps() As CoordType
    
    Dim thisLine As LineType
    Dim nextLine As LineType
    Dim thisArc As ArcType
    Dim nextArc As ArcType
    
    Dim temp As Variant
    
    Dim tempEntity As EntityType
    tempEntity = plnEty
    
    
    If plnEty.ELayer = 1 Then
        plnEty.ELayer = 1
    End If
    
    '把参数传递过来的点序列PSquence与边界对齐
    For i = 0 To eleNum - 1
        If i < eleNum - 1 Then
            ReDim Preserve ps(i + 1)
            ps(i + 1) = PSquence(i)
        Else
            ps(0) = PSquence(i)
        End If
    Next i
    
     
    '修改 ECoord 的值
    For i = 0 To eleNum - 1
        
        If i = 5 Then
            i = 5
        End If
        
        If plnEty.EConvex(i) = 0 Then                   '与下点间为直线
        
            If i = eleNum - 1 Then
                thisLine = getLine(ps(i), ps(0))
                If plnEty.EConvex(0) = 0 Then           '下一段为直线
                    nextLine = getLine(ps(0), ps(1))
                    tempEntity.ECoord(0) = getLine_LineIntersection(thisLine, nextLine, 1)
                Else                                        '下一段为弧
                    nextArc = getArc(plnEty, 0)
                    nextArc.ARadius = getNextArcRadius(ps(0), ps(1), plnEty.ECoord(0), nextArc, dis, eleNum)
                    temp = getLine_ArcIntersection(thisLine, nextArc, 1)
                    tempEntity.ECoord(0) = getNearPoint(temp, plnEty.ECoord(0))
                End If
            Else
                If i = eleNum - 2 Then
                    thisLine = getLine(ps(i), ps(i + 1))
                    If plnEty.EConvex(i + 1) = 0 Then           '下一段为直线
                        nextLine = getLine(ps(i + 1), ps(0))
                        tempEntity.ECoord(i + 1) = getLine_LineIntersection(thisLine, nextLine, 1)
                    Else                                        '下一段为弧