gcodes.bas

老外用VB写的CNC仿真程序源码

Attribute VB_Name = "GCodes"
Option Explicit
Private Type Point  'defines a point
    X As Double
    Y As Double
End Type
Public XYArray() As Point   'stores the points of tool movement
Private AxialRelief, RadialRelief, NumberOfPasses As Integer
Private DepthOfCut, RadialToolRetraction As Integer
Public FastSpeed As Boolean

Public Sub ExecuteG00()
    Dim XInc, YInc As Integer
    Dim i, NumSteps As Integer
    Dim X1, X2, Y1, Y2 As Integer
    
    X1 = FromZ  'starting x coordinate = starting z position
    X2 = ToZ    'end x coordinate
    Y1 = FromX  'start y coordinate = starting x position
    Y2 = ToX    'end y coordinate
    
    'calculate number of steps required
    If Abs(X1 - X2) > Abs(Y2 - Y1) Then
        NumSteps = Abs(X1 - X2)
    Else
        NumSteps = Abs(Y1 - Y2)
    End If
    
    If X2 = X1 Then
        XInc = 0
    Else
        XInc = (X2 - X1) / Abs(X2 - X1)
    End If
    
    If Y2 = Y1 Then
        YInc = 0
    Else
        YInc = (Y2 - Y1) / Abs(Y2 - Y1)
    End If
        
    ReDim XYArray(NumSteps) 'redimension array to required number of steps
    
    XYArray(0).X = X1   'start point
    XYArray(0).Y = Y1
    
    For i = 1 To NumSteps
        If X1 <> X2 Then X1 = X1 + XInc
        If Y1 <> Y2 Then Y1 = Y1 + YInc
        XYArray(i).X = X1
        XYArray(i).Y = Y1
    Next i
    FastSpeed = True
    Run
    FromX = ToX
    FromZ = ToZ
    FastSpeed = False
End Sub

Public Sub ExecuteG01()
    Dim XInc, YInc As Double
    Dim i, NumSteps, DX, DY As Integer
    Dim X2, Y2 As Integer
    Dim X1, Y1 As Double
    X1 = FromZ  'starting x coordinate = starting z position
    X2 = ToZ    'end x coordinate
    Y1 = FromX  'start y coordinate = starting x position
    Y2 = ToX    'end y coordinate
    DX = X2 - X1
    DY = Y2 - Y1
    'calculate number of steps required
    If Abs(X1 - X2) > Abs(Y2 - Y1) Then
        NumSteps = Abs(X1 - X2)
    Else
        NumSteps = Abs(Y1 - Y2)
    End If
    If NumSteps = 0 Then Exit Sub
    XInc = DX / CDbl(NumSteps)
    YInc = DY / CDbl(NumSteps)
    
    If XInc <> 0 And YInc <> 0 Then
        TAPER = 1
    Else
        TAPER = 0
    End If
    
    ReDim XYArray(NumSteps) 'redimension array to required number of steps
    XYArray(0).X = X1   'start point
    XYArray(0).Y = Y1
    For i = 1 To NumSteps
        X1 = X1 + XInc
        Y1 = Y1 + YInc
        XYArray(i).X = X1
        XYArray(i).Y = Y1
    Next i
    FastSpeed = False
    Run
    FromX = ToX
    FromZ = ToZ
End Sub

'G02 - Clockwise Arc
Public Sub ExecuteG02()
    Dim X1, X2, Y1, Y2 As Double
    Dim m, theta, Theta1, Theta2 As Double
    Dim Xm, Ym, B, L, Xc, Yc, X0, Y0, R, DX, DY As Double
    
    X1 = FromZ  'starting x coordinate = starting z position
    X2 = ToZ    'end x coordinate
    Y1 = FromX  'start y coordinate = starting x position
    Y2 = ToX    'end y coordinate
    
    If RFound = False Then
        Xc = X1 + IVal
        Yc = Y1 + KVal
        R = Sqr((Xc - X1) ^ 2 + (Yc - Y1) ^ 2)
    Else
        R = RVal
    End If
    RFound = False
    
     If Abs(Y2 - Y1) < 0.1 Then
        Y1 = Y1 - 0.01
        B = 0.5 * Sqr((X1 - X2) ^ 2)
        m = (X1 - X2) / CDbl(0.01)
    Else
        B = 0.5 * Sqr((X1 - X2) ^ 2 + (Y1 - Y2) ^ 2)
        m = (X1 - X2) / CDbl(Y2 - Y1)
    End If
    theta = Atn(m)
    
    Xm = (X1 + X2) / 2#
    Ym = (Y1 + Y2) / 2#

    If Abs(R) < Abs(B) Then
        MsgBox "Value of Radius is too small to draw", vbInformation + vbOKOnly, "Error!"
        Exit Sub
    End If
    L = Sqr(R ^ 2 - B ^ 2)
    
    DY = Y2 - Y1
    DX = X2 - X1
    
    If DX < 0 Then DX = -DX
    Xc = Xm + L * Cos(theta) * (R * DY * DX / (Abs(R) * Abs(DY) * Abs(DX))) ' multiply by sign of r*y
    Yc = Ym + L * Sin(theta) * (R * DY * DX / (Abs(DX) * Abs(R) * Abs(DY))) 'multiple by inverse sign of R
    
        If (Abs(X1 - Xc) < 0.1) Then X1 = X1 + 0.1
        Theta1 = Atn(Abs(Y1 - Yc) / Abs(X1 - Xc))
        'decide the quadrant
        DX = X1 - Xc
        DY = Y1 - Yc
        If DX > 0 And DY > 0 Then
            Theta1 = Theta1
        ElseIf DX < 0 And DY > 0 Then
            Theta1 = 3.14159 - Theta1
        ElseIf DX < 0 And DY < 0 Then
            Theta1 = 3.14159 + Theta1
        Else
            Theta1 = 3.14159 * 2 - Theta1
        End If
    
        If (Abs(X2 - Xc) < 0.1) Then X2 = X2 + 0.1
        Theta2 = Atn(Abs(Y2 - Yc) / Abs(X2 - Xc))
        DX = X2 - Xc
        DY = Y2 - Yc
    
        If DX >= 0 And DY >= 0 Then
            Theta2 = Theta2
        ElseIf DX < 0 And DY >= 0 Then
            Theta2 = 3.14159 - Theta2
        ElseIf DX < 0 And DY < 0 Then
            Theta2 = 3.14159 + Theta2
        Else
            Theta2 = 3.14159 * 2 - Theta2
        End If
    'End If
    
    Dim angle, X, Y, step As Integer
   
    ReDim XYArray(0)
    X = X1
    Y = Y1
    XYArray(0).X = X
    XYArray(0).Y = Y
    
    Dim i As Integer
    i = 1
    
    If Theta2 > Theta1 Then Theta2 = Theta2 - 2 * 3.14159
    
    X = X1
    Y = Y1
    For angle = Theta1 To Theta2 Step -0.002
        X = Abs(R) * Cos(angle) + Xc
        Y = Abs(R) * Sin(angle) + Yc
        
        ReDim Preserve XYArray(i)
        XYArray(i).X = X
        XYArray(i).Y = Y
        i = i + 1
    Next angle
    FastSpeed = False
    Run
    FromX = ToX
    FromZ = ToZ
End Sub

Public Sub ExecuteG03()
    Dim X1, X2, Y1, Y2 As Double
    Dim m, theta, Theta1, Theta2 As Double
    Dim Xm, Ym, B, L, Xc, Yc, X0, Y0, R, DX, DY As Double
    
    X1 = FromZ  'starting x coordinate = starting z position
    X2 = ToZ    'end x coordinate
    Y1 = FromX  'start y coordinate = starting x position
    Y2 = ToX    'end y coordinate
    
    If RFound = False Then
        Xc = X1 + IVal
        Yc = Y1 + KVal
        R = Sqr((Xc - X1) ^ 2 + (Yc - Y1) ^ 2)
    Else
        R = RVal
    End If
    RFound = False
    
    If Abs(Y2 - Y1) < 0.1 Then
        Y1 = Y1 - 0.01
        B = 0.5 * Sqr((X1 - X2) ^ 2)
        m = (X1 - X2) / CDbl(0.01)
    Else
        B = 0.5 * Sqr((X1 - X2) ^ 2 + (Y1 - Y2) ^ 2)
        m = (X1 - X2) / CDbl(Y2 - Y1)
    End If
    
    theta = Atn(m)
    
    Xm = (X1 + X2) / 2#
    Ym = (Y1 + Y2) / 2#
    
    
    If Abs(R) < Abs(B) Then
        MsgBox "Value of Radius is too small to draw", vbInformation + vbOKOnly, "Error!"
        Exit Sub
    End If
    L = Sqr(R ^ 2 - B ^ 2)
    
    DY = Y2 - Y1
    DX = X2 - X1
    
    If DX > 0 Then DX = -DX
    Xc = Xm + L * Cos(theta) * (R * DY * DX / (Abs(R) * Abs(DY) * Abs(DX))) ' multiply by sign of r*y
    Yc = Ym + L * Sin(theta) * (R * DY * DX / (Abs(DX) * Abs(R) * Abs(DY))) 'multiple by inverse sign of R
    
        If (Abs(X1 - Xc) < 0.1) Then X1 = X1 + 0.1
        Theta1 = Atn(Abs(Y1 - Yc) / Abs(X1 - Xc))
        'decide the quadrant
        DX = X1 - Xc
        DY = Y1 - Yc
        If DX > 0 And DY > 0 Then
            Theta1 = Theta1
        ElseIf DX < 0 And DY > 0 Then
            Theta1 = 3.14159 - Theta1
        ElseIf DX < 0 And DY < 0 Then
            Theta1 = 3.14159 + Theta1
        Else
            Theta1 = 3.14159 * 2 - Theta1
        End If
        
        If (Abs(X2 - Xc) < 0.1) Then X2 = X2 + 0.1
        Theta2 = Atn(Abs(Y2 - Yc) / Abs(X2 - Xc))
        DX = X2 - Xc
        DY = Y2 - Yc
    
        If DX >= 0 And DY >= 0 Then
            Theta2 = Theta2
        ElseIf DX < 0 And DY >= 0 Then
            Theta2 = 3.14159 - Theta2
        ElseIf DX < 0 And DY < 0 Then
            Theta2 = 3.14159 + Theta2
        Else
            Theta2 = 3.14159 * 2 - Theta2
        End If
    'End If
    
    Dim angle, X, Y, step As Integer
    ReDim XYArray(1)
    X = X1
    Y = Y1
    
    XYArray(0).X = X
    XYArray(0).Y = Y
    Dim i As Integer
    i = 1
    
    If Theta2 < Theta1 Then Theta1 = Theta1 - 2 * 3.14159
    
    For angle = Theta1 To Theta2 Step 0.002
        X = Abs(R) * Cos(angle) + Xc
        Y = Abs(R) * Sin(angle) + Yc
        
        ReDim Preserve XYArray(i)
        XYArray(i).X = X
        XYArray(i).Y = Y
        i = i + 1
    Next angle
    
    Run

    FromX = ToX
    FromZ = ToZ
End Sub

Public Sub ExecuteG28()
    'go to intermediate point
    'check for case U0 W0
    If FromX <> ToX Or FromZ <> ToZ Then
        ExecuteG01
    End If
    
    'calculate home position
    FromX = ToX
    FromZ = ToZ
    ToX = CInt(PicHeight / 2 - ToolHeight - 5)
    ToZ = PicWidth - WorkPieceLength - ToolWidth - 10
    
    'go to home position
    ExecuteG00
    FromX = ToX
    FromZ = ToZ
End Sub


Public Sub ExecuteG90()
    Dim X1, Z1, X2, Z2, R As Integer
    
    X1 = FromX
    Z1 = FromZ
    X2 = ToX
    Z2 = ToZ
    
    If RFound = False Then
        R = 0
    Else
        R = RVal
        RFound = False
    End If
    
    'first point
    ToX = X2 + R
    ToZ = Z1
'    frmMain.StatusBar.Panels(2).Text = "Feed: Maximum"
    ExecuteG00
    
    'second point
    FromX = ToX
    FromZ = ToZ
    ToX = X2
    ToZ = Z2
 '   frmMain.StatusBar.Panels(2).Text = "Feed: " & FeedRate
    ExecuteG01
    
    'third point
    FromX = ToX
    FromZ = ToZ
    ToX = X1
    ToZ = Z2
  '  frmMain.StatusBar.Panels(2).Text = "Feed: " & FeedRate
    ExecuteG01
    
    'final point
    FromX = ToX
    FromZ = ToZ
    ToX = X1
    ToZ = Z1
'    frmMain.StatusBar.Panels(2).Text = "Feed: Maximum"
    ExecuteG00
    
    'Reset initial point
    FromX = X1
    FromZ = Z1
    ToX = X2
    ToZ = Z2
    
End Sub

Public Sub ExecuteG94()
    Dim X1, Z1, X2, Z2, R As Integer
    
    X1 = FromX
    Z1 = FromZ
    X2 = ToX
    Z2 = ToZ
    
    If RFound = False Then
        R = 0
    Else
        R = RVal
        RFound = False
    End If
    
    'first point
    ToX = X1
    ToZ = Z2 + R
'    frmMain.StatusBar.Panels(2).Text = "Feed: Maximum"
    ExecuteG00
    
    'second point
    FromX = ToX
    FromZ = ToZ
    ToX = X2
    ToZ = Z2
 '   frmMain.StatusBar.Panels(2).Text = "Feed: " & FeedRate
    ExecuteG01
    
    'third point
    FromX = ToX
    FromZ = ToZ
    ToX = X2
    ToZ = Z1
  '  frmMain.StatusBar.Panels(2).Text = "Feed: " & FeedRate
    ExecuteG01
    
    'final point
    FromX = ToX
    FromZ = ToZ
    ToX = X1
    ToZ = Z1
   ' frmMain.StatusBar.Panels(2).Text = "Feed: Maximum"
    ExecuteG00
    
    'Reset initial point
    FromX = X1
    FromZ = Z1
    ToX = X2
    ToZ = Z2
    
End Sub

Public Sub ExecuteG04()

    If PVal <> 0 Then
        Sleep PVal
    ElseIf UVal <> 0 Then
        Sleep UVal * 1000
    Else
        Sleep ToX
    End If
End Sub

Public Sub ExecuteG73()
    Static G73SecondTime As Boolean
    Dim StartingPoint As Point
    
    'agar pehali baar call kiya hai to isliye
    If G73SecondTime = False Then
        G73SecondTime = True
        AxialRelief = WVal
        RadialRelief = UVal * 2
        NumberOfPasses = RVal / 10
        ToX = ToX - UVal 'kyonki uval tox ki val change kar deta hai
        ToZ = ToZ - WVal 'upar wala funda
        Exit Sub
    End If
    
    'Doosri baar call karne par
    StartingPoint.X = FromZ
    StartingPoint.Y = FromX
    G73SecondTime = False
    PVal = PVal / 10
    QVal = QVal / 10
    ToX = ToX - UVal 'kyonki uval tox ki val change kar deta hai
    ToZ = ToZ - WVal 'upar wala funda
    ShiftX = RadialRelief
    ShiftZ = AxialRelief
    Dim i1, i2, i As Integer
    Dim TxtToSearch As String
    Dim NFound As Integer
    
    'Searching for I1 = start point
    NFound = -1
    TxtToSearch = "N" & PVal
    For i = 0 To frmMain.DebugWindow.Rows - 1
        NFound = InStr(frmMain.DebugWindow.TextMatrix(i, 2), TxtToSearch)
        If NFound <> 0 Then
            i1 = i
'            MsgBox i1 & " " & CodeArray(i)
            Exit For
        End If
    Next i
    
    'Searching for I2 = End point
    NFound = -1
    TxtToSearch = "N" & QVal
    For i = i1 + 1 To frmMain.DebugWindow.Rows - 1
        NFound = InStr(frmMain.DebugWindow.TextMatrix(i, 2), TxtToSearch)
        If NFound <> 0 Then
            i2 = i
'            MsgBox i2 & " " & CodeArray(i)
            Exit For
        End If
    Next i

Dim Iteration As Integer
  For Iteration = 1 To NumberOfPasses
      For i = i1 To i2
            
            If StopSimulation = True Then
                Exit Sub
            End If
            
            frmMain.RemoveHighLighting (i - 1)
            frmMain.HighLightExecutingLine (i)
    
            If Left(frmMain.DebugWindow.TextMatrix(i, 2), 1) = "[" Then GoTo Nextline   'encountered a comment
    
            Dim j As Integer    'search for comment at the end of line
            j = InStr(frmMain.DebugWindow.TextMatrix(i, 2), "[")
            
            If j = 0 Then  'no comment found
                Process (frmMain.DebugWindow.TextMatrix(i, 2)) ' process each line
            Else    'remove comment and process line
                Process (Left(frmMain.DebugWindow.TextMatrix(i, 2), j - 1)) ' process each line
            End If
Nextline:
        
        Next i
       
        ToX = StartingPoint.Y + ShiftX + UVal 'profile se bahar aane ke liye
        ToZ = StartingPoint.X + ShiftZ + WVal
        FromX = FromX + ShiftX / (NumberOfPasses - 1)
        FromZ = FromZ + ShiftZ / (NumberOfPasses - 1)
        ExecuteG01
        ShiftX = ShiftX - RadialRelief / (NumberOfPasses - 1) + UVal
        ShiftZ = ShiftZ - AxialRelief / (NumberOfPasses - 1) + WVal
        
        
    Next Iteration
    CurrentLineNumber = i2
    ShiftX = 0
    ShiftZ = 0
    
End Sub