frmopen.frm

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

    Dim i As Double
    Dim j As Double
    Dim angle As Double
    Dim lastAngle As Double
    Dim temp As CoordType
    Dim PI As Double
    PI = 3.141592653589
    
    If p < pEty.EPnum - 1 Then
        i = getDistance(pEty.ECoord(p), pEty.ECoord(p + 1))
    
        temp.CX = (pEty.ECoord(p).CX + pEty.ECoord(p + 1).CX) / 2
        temp.CY = (pEty.ECoord(p).CY + pEty.ECoord(p + 1).CY) / 2
    Else
        i = getDistance(pEty.ECoord(p), pEty.ECoord(0))
    
        temp.CX = (pEty.ECoord(p).CX + pEty.ECoord(0).CX) / 2
        temp.CY = (pEty.ECoord(p).CY + pEty.ECoord(0).CY) / 2
    End If
    
    j = getDistance(getArc(pEty, p).ACentre, temp)
    
    If j = 0 Then
        getConvex = 1
    Else
        angle = Atn(i / (2 * j))
        angle = angle * 2#
    
        lastAngle = 4# * (Atn(Abs(pEty.EConvex(p))))
    
        If (lastAngle - PI) > 0 Then
            getConvex = Tan((2 * PI - angle) / 4#)
        Else
            getConvex = Tan(angle / 4#)
        End If
    End If
    
    If pEty.EConvex(p) > 0 Then
        getConvex = Abs(getConvex)
    Else
        getConvex = -Abs(getConvex)
    End If
        
End Function
Private Function getRadius(plnEty As EntityType, pn As Long, dis As Double) As Double
    
    Dim ln As LineType
    Dim Line1 As LineType
    Dim Line2 As LineType
    Dim arc0 As ArcType
    
    If pn < plnEty.EPnum - 1 Then
        ln = getLine(plnEty.ECoord(pn), plnEty.ECoord(pn + 1))
        arc0 = getArc(plnEty, 0)
    Else
        ln = getLine(plnEty.ECoord(pn), plnEty.ECoord(0))
        arc0 = getArc(plnEty, pn)
    End If
    
    Dim temp0 As Variant
    temp = getNearLine(ln, 0.05)
    Line1.LK = temp(0)
    Line1.LB = temp(1)
    Line2.LK = temp(2)
    Line2.LB = temp(3)
    
    Dim temp1 As Variant
    temp1 = getLine_ArcIntersection(Line1, arc0)
        
    
End Function

Private Function getNearLine(LnEqu As LineType, h As Double) As Variant

    Dim Line1 As LineType
    Dim Line2 As LineType
    
    Line1.LK = LnEqu.LK
    Line2.LK = LnEqu.LK
    
    If IsNull(LnEqu.LK) Then
        Line1.LB = LnEqu.LB + h
        Line2.LB = LnEqu.LB - h
    Else
        Line1.LB = LnEqu.LB + h * Sqr((LnEqu.LK ^ 2) + 1)
        Line2.LB = LnEqu.LB - h * Sqr((LnEqu.LK ^ 2) + 1)
    End If
    
    getNearLine = Array(Line1.LK, Line1.LB, Line2.LK, Line2.LB)
    
End Function
'#############################################################################
'求两个点的pointAry中，距离点p较近的一个点
Private Function getNearPoint(pointAry As Variant, p As CoordType) As CoordType
    
    Dim p1 As CoordType
    Dim p2 As CoordType
    
    p1.CX = pointAry(0)
    p1.CY = pointAry(1)
    p2.CX = pointAry(2)
    p2.CY = pointAry(3)
    
    Dim s1 As Double
    Dim s2 As Double
    
    s1 = getDistance(p1, p)
    s2 = getDistance(p2, p)
    
    If s1 < s2 Then
        getNearPoint.CX = p1.CX
        getNearPoint.CY = p1.CY
    Else
        getNearPoint.CX = p2.CX
        getNearPoint.CY = p2.CY
    End If

    
    
End Function
'#############################################################################
'求整数DNum的二进制表示的第bit位
Private Function Bin(DNum As Long, bit As Long) As Long

    Dim ONum As String
    
    ONum = CStr(Oct(DNum))
    
    ONum = Replace(ONum, "0", "000")
    ONum = Replace(ONum, "1", "001")
    ONum = Replace(ONum, "2", "010")
    ONum = Replace(ONum, "3", "011")
    ONum = Replace(ONum, "4", "100")
    ONum = Replace(ONum, "5", "101")
    ONum = Replace(ONum, "6", "110")
    ONum = Replace(ONum, "7", "111")
    
    If bit > Len(ONum) - 1 Then
        Bin = 0
    Else
        Bin = Mid$(ONum, Len(ONum) - bit, 1)
    End If
    
End Function
'#############################################################################
'处理实体的边缘
Private Sub dealEdge(ETElement As EntityType)
        
    Select Case ETElement.EName
    
        Case "CIRCLE"
            generateCircleEageInstruction ETElement
            
        Case "LINE"
            generateLineInstruction ETElement
            
        Case "POINT"
            generatePointInstruction ETElement
        
        Case "LWPOLYLINE"
            generateLwpolylineEageInstruction ETElement
        
    End Select
      
End Sub
'#############################################################################
'产生圆的指令，读到指令序列数组InstructionSquence中
Private Sub generateCircleEageInstruction(circleEntity As EntityType)
    
    Dim layer As Long
    Dim depth As Double
    Dim p As CoordType                  '圆心坐标
    Dim angle As Double
    Dim radius As Double
    
    Dim ch As Long
    Dim ch1 As Long
    Dim ch2 As Long
    Dim step As Double
    Dim cen1 As Double
    Dim cen2 As Double
    Dim pos1 As Double
    Dim pos2 As Double
    
    '"CIRCLE", p, depth, radius
    
    layer = circleEntity.ELayer
    
    depth = circleEntity.EDepth + standHigh
    
    radius = circleEntity.EConvex(0)
    
    '寻校准点
    ch1 = 1
    ch2 = 2
    p = getCorrectPoint()
    pos1 = p.CX - Last.CX
    pos2 = p.CY - Last.CY
    addToArray "find_fast_line2 " & ch1 & " " & pos1 & " " & ch2 & " " & pos2 & " ", InstructionSquence()
    Last.CX = Last.CX + pos1
    Last.CY = Last.CY + pos2
            
    '插入
    ch = 3
    step = depth
    addToArray "fast_pmove " & ch & " " & step & " ", InstructionSquence()
    
    '寻起始点
    ch1 = 1
    ch2 = 2
    p = circleEntity.ECoord(0)
    pos1 = p.CX - Last.CX
    pos2 = p.CY - Last.CY
    addToArray "find_fast_line2 " & ch1 & " " & pos1 & " " & ch2 & " " & pos2 & " ", InstructionSquence()
    Last.CX = Last.CX + pos1
    Last.CY = Last.CY + pos2
        
    '画圆
    ch1 = 1
    ch2 = 2
    cen1 = p.CX - Last.CX
    cen2 = p.CY - Last.CY
    angle = -360
    addToArray "cut_fast_arc_center " & ch1 & " " & ch2 & " " & cen1 & " " & cen2 & " " & angle & " )", InstructionSquence()
    
    '拔出
    ch = 3
    step = -depth
    addToArray "fast_pmove " & ch & " " & step & " ", InstructionSquence()
        
        
End Sub
'#############################################################################
'产生线的指令，读到指令序列数组InstructionSquence中
Private Sub generateLineInstruction(lineEntity As EntityType)

    ' "LINE", p1, p2, depth
    
    Dim p1 As CoordType
    Dim p2 As CoordType
    Dim depth As Double
    Dim pos1 As Double
    Dim pos2 As Double
    Dim ch As Long
    Dim ch1 As Long
    Dim ch2 As Long
    Dim step As Double
    
    p1 = lineEntity.ECoord(0)
    p2 = lineEntity.ECoord(1)
    
    depth = lineEntity.EDepth + standHigh
    
    '寻点
    ch1 = 1
    ch2 = 2
    pos1 = p1.CX - Last.CX
    pos2 = p1.CY - Last.CY
    addToArray "find_fast_line2 " & ch1 & " " & pos1 & " " & ch2 & " " & pos2 & " ", InstructionSquence()
    Last.CX = Last.CX + pos1
    Last.CY = Last.CY + pos2
        
    '插入
    ch = 3
    step = depth
    addToArray "fast_pmove " & ch & " " & step & " ", InstructionSquence()
        
    '画线
    ch1 = 1
    ch2 = 2
    pos1 = p2.CX - p1.CX
    pos2 = p2.CY - p1.CY
    addToArray "cut_fast_line2 " & ch1 & " " & pos1 & " " & ch2 & " " & pos2 & " ", InstructionSquence()
    Last.CX = Last.CX + pos1
    Last.CY = Last.CY + pos2
        
    '拔出
    ch = 3
    step = -depth
    addToArray "fast_pmove " & ch & " " & step & " ", InstructionSquence()

End Sub
'#############################################################################
'产生点的指令，读到指令序列数组InstructionSquence中
Private Sub generatePointInstruction(pointEntity As EntityType)

    ' "POINT", x, y, depth
    Dim p As CoordType
    Dim depth As Double
    Dim pos1 As Double
    Dim pos2 As Double
    Dim step As Double
    Dim ch As Long
    Dim ch1 As Long
    Dim ch2 As Double
    
    p = pointEntity.ECoord(0)
    
    depth = pointEntity.EDepth + standHigh

    '寻点
    ch1 = 1
    ch2 = 2
    pos1 = p.CX - Last.CX
    pos2 = p.CY - Last.CY
    addToArray "fast_line2 " & ch1 & " " & pos1 & " " & ch2 & " " & pos2 & " ", InstructionSquence()
    Last.CX = Last.CX + pos1
    Last.CY = Last.CY + pos2
        
    '插入
    ch = 3
    step = depth
    addToArray "fast_pmove " & ch & " " & step & " ", InstructionSquence()
                
    '拔出
    ch = 3
    step = -depth
    addToArray "fast_pmove " & ch & " " & step & " ", InstructionSquence()

End Sub
'#############################################################################
'产生多线段的指令，读到指令序列数组InstructionSquence中
Private Sub generateLwpolylineEageInstruction(lwpolylineEntity As EntityType)

    Dim ch As Long
    Dim ch1 As Long
    Dim ch2 As Long
    Dim p As CoordType
    Dim pos1 As Double
    Dim pos2 As Double
    Dim cen1 As Double
    Dim cen2 As Double
    Dim depth As Double
    Dim angle As Double
    Dim step As Double
    Dim layer As Long
    Dim i As Long
    Dim p1 As CoordType
    Dim p2 As CoordType
    Dim theArc As ArcType
    
    depth = lwpolylineEntity.EDepth + standHigh
    
    Dim eleNum As Long
    eleNum = lwpolylineEntity.EPnum
    
    '寻校准点
    ch1 = 1
    ch2 = 2
    p = getCorrectPoint()
    pos1 = p.CX - Last.CX
    pos2 = p.CY - Last.CY
    addToArray "find_fast_line2 " & ch1 & " " & pos1 & " " & ch2 & " " & pos2 & " ", InstructionSquence()
    Last.CX = Last.CX + pos1
    Last.CY = Last.CY + pos2
            
    '插入
    ch = 3
    step = depth
    addToArray "fast_pmove " & ch & " " & step & " ", InstructionSquence()
    
    '寻起始点
    ch1 = 1
    ch2 = 2
    p = lwpolylineEntity.ECoord(0)
    pos1 = p.CX - Last.CX
    pos2 = p.CY - Last.CY
    addToArray "find_fast_line2 " & ch1 & " " & pos1 & " " & ch2 & " " & pos2 & " ", InstructionSquence()
    Last.CX = Last.CX + pos1
    Last.CY = Last.CY + pos2
    
    '走多线段
    For i = 0 To eleNum - 1             '按点序切
    
        p1 = lwpolylineEntity.ECoord(i)
            
        If i < eleNum - 1 Then          '未到达最后一点
            p2 = lwpolylineEntity.ECoord(i + 1)
        Else                          '到达最后一点
            p2 = lwpolylineEntity.ECoord(0)
        End If
            
        If lwpolylineEntity.EConvex(i) = 0 Then  '凸度为0，这一点与下一点间为直线
            ch1 = 1
            ch2 = 2
            pos1 = p2.CX - p1.CX
            pos2 = p2.CY - p1.CY
                
            addToArray "cut_fast_line2 " & ch1 & " " & pos1 & " " & ch2 & " " & pos2 & " ", InstructionSquence()
            
            Last.CX = Last.CX + pos1
            Last.CY = Last.CY + pos2
        Else                                    '凸度不为0，这一点与下点间为弧
            theArc = getArc(lwpolylineEntity, i)
            ch1 = 1
            ch2 = 2
            cen1 = theArc.ACentre.CX - p1.CX
            cen2 = theArc.ACentre.CY - p1.CY
            angle = theArc.AAngle