prgcontrolfrm.frm

数控切割控制系统,需要DLPORTIO,通过控制8位的并口的电位高低来4路控制数控切割机

'
'    xInterval = CInt(Ax / dFx)
'    XTimer.Interval = xInterval
'    XTimer.Enabled = True
'
'    yInterval = CInt(Ay / dFy)
'    YTimer.Interval = yInterval
'    YTimer.Enabled = True
'End Sub

Public Function SendLineSignal(ByVal dX0 As Double, ByVal dY0 As Double, ByVal dX1 As Double, ByVal dY1 As Double) As Boolean
'    Dim xInterval As Integer
'    Dim yInterval As Integer
'    Dim Fx As Double
'    Dim Fy As Double
'    Dim xDistance, yDistance As Double
'
'    If (F = 0) Then
'        SendLineSignal = False
'        Exit Function
'    End If
'
'    Fx = F * (dX1 - dX0) / Sqr((dX1 - dX0) * (dX1 - dX0) + (dY1 - dY0) * (dY1 - dY0))
'    Fy = F * (dY1 - dY0) / Sqr((dX1 - dX0) * (dX1 - dX0) + (dY1 - dY0) * (dY1 - dY0))
'
'    xCount = CLng(Abs(X1 - X0) / Ax)
'    yCount = CLng(Abs(X1 - X0) / Ay)
'
'    xInterval = CInt(Ax * 60 / Fx)
'    XTimer.Interval = Abs(xInterval)
'
'    yInterval = CInt(Ay * 60 / Fy)
'    YTimer.Interval = Abs(yInterval)
'
'    XTimer.Enabled = True
'    YTimer.Enabled = True
'
'    SendLineSignal = True
'
'DrawLine:
'    Do While (XTimer.Enabled Or YTimer.Enabled)
'        DoEvents
'       ' Me.Show vbModal
'    Loop
'    If (xCount <= xStartCount) And (yCount <= yStartCount) Then
'        X0 = X2
'        Y0 = Y2
'    Else
'        Do While (Not XTimer.Enabled And Not YTimer.Enabled)
'            DoEvents
'        Loop
'        GoTo DrawLine
'   End If

'================================================================

    Shape = 1
    Dim iInterval As Double
    Dim lDistance As Double
    Dim lTime As Long

    
    Ax0 = Ax
    Ay0 = Ay
    
    lDistance = Sqr((dX1 - dX0) * (dX1 - dX0) + (dY1 - dY0) * (dY1 - dY0))
    lTime = CLng(lDistance * 60 / F)

    iInterval = lTime / (Abs((dX1 - dX0) / Ax) + Abs((dY1 - dY0) / Ay))
    If (iInterval < 1) And (iInterval > 0) Then
        Timer.Interval = 1
    Else
        Timer.Interval = iInterval
    End If
    
    If (iInterval > 0) Then
        Timer.Enabled = True
    Else
        SendLineSignal = True
        Exit Function
    End If

    If (dX0 = dX1) And (dY1 = dY0) Then
        Timer.Enabled = False
        SendLineSignal = True
        Exit Function
    End If

    iTag = 0

    dx = Abs(dX1 - dX0)
    dy = Abs(dY1 - dY0)
    
    If (Ay * dx < Ax * dy) Then
        iTag = 1

        XY = dX1
        dX1 = dY1
        dY1 = XY

        XY = dX0
        dX0 = dY0
        dY0 = XY

        Dxy = dx
        dx = dy
        dy = Dxy
    
        Dxy = Ax0
        Ax0 = Ay0
        Ay0 = Dxy
    End If

    tx = IIf(dX1 > dX0, Ax0, -Ax0)
    ty = IIf(dY1 > dY0, Ay0, -Ay0)

    curx = dX0
    cury = dY0

    OldPx = dX0
    OldPy = dY0

    inc1 = 2 * dy * Ax0
    inc2 = 2 * (dy * Ax0 - dx * Ay0)

    d = inc1 - dx * Ay0

    SendLineSignal = True
    
    If (dX0 = dX01) Then
       DirectX = True
    End If
    
    If (dY0 = dY01) Then
       DirectY = True
    End If
    
    If (DirectX And DirectY) Then
        Exit Function
    End If
    
DrawLine:
    Do While (Timer.Enabled)
        DoEvents
    Loop
    If ((iTag = 0) And (Abs(curx - dX01) <= Ax0) Or ((iTag = 1) And (Abs(curx - dY01) <= Ax0))) Then
        X0 = X1
        Y0 = Y1
        DirectX = False
        DirectY = False
        If Not bDrawCircle Then
            StopGoOnCmd.Enabled = False
        End If
    Else
        Do While (Not Timer.Enabled)
            DoEvents
        Loop
        GoTo DrawLine
    End If
End Function

Private Sub GoOnCmd_Click()
    StopGoOnCmd.Enabled = True
'    XTimer.Enabled = True
'    YTimer.Enabled = True
    GoOnCmd.Enabled = False
    Timer.Enabled = True
    If (bDrawCircle) Then
        CircleGoOn = True
    End If
'    CircleGoOn = True
    'StopNow = False
End Sub

Private Sub pGoOnCmd_Click()
    Dim i1 As Integer
    Dim Mystr As String
    Dim bAccess_File As Boolean
    
    StopGoOnCmd.Enabled = True
    pGoOnCmd.Enabled = False
    M = 1
    Close #1
    Open ProgramFileName For Input As #1
        Do While Not EOF(1)
            For i1 = 1 To PrgFileLineNumber
                Input #1, Mystr
            Next i1
            
'            On Error GoTo errHandler
            If Not EOF(1) Then
                Input #1, Mystr
                
                bAccess_File = DivideLine(Mystr)
                
'                If (M = 2) Then
'                    pGoOnCmd.Enabled = False
'                    Exit Do
'                End If
'
'                If (M = 0) Then
'                    PrgFileLineNumber = PrgFileLineNumber + 1
'
'                    pGoOnCmd.Enabled = True
'                    Close #1
'                    Exit Sub
'                Else
'                    If (M = 1) Then
'                        pGoOnCmd.Enabled = False
'                    End If
'                End If
                
                If Not bAccess_File Then
                    Close #1
                    PrgFileLineNumber = 0
                    MsgBox "代码文件有错3", vbInformation, "提示"
                    Unload Me
                    MainFrm.Show vbModal
                End If
                
                If (G0 = 1) Then '直线
                    dX01 = X1
                    dY01 = Y1
                    bAccess_File = SendLineSignal(X0, Y0, X1, Y1)
                Else
                    bAccess_File = SendCircleSignal
                    I = 0
                    J = 0
                    r = 0
                End If
                If Not bAccess_File Then
                    Close #1
                    PrgFileLineNumber = 0
                    MsgBox "代码文件有错4", vbInformation, "提示"
                    Unload Me
                    MainFrm.Show vbModal
                Else
                    X0 = X1
                    Y0 = Y1
                End If
                
                If (M = 2) Then
                    pGoOnCmd.Enabled = False
                    Exit Do
                End If
                
                If (M = 0) Then
                    PrgFileLineNumber = PrgFileLineNumber + 1
                
                    pGoOnCmd.Enabled = True
                    Close #1
                    Exit Sub
                Else
                    If (M = 1) Then
                        pGoOnCmd.Enabled = False
                    End If
                End If
            Else
                pGoOnCmd.Enabled = False
            End If
        Loop
    Close #1
    
'errHandler:
'    Close #1
'    If Err.Number = 62 Then
'        MsgBox "代码文件有错5!", vbInformation, "提示"
'    End If
End Sub

Private Sub stopCmd_Click()
'    YTimer.Enabled = False
'    XTimer.Enabled = False
    Timer.Enabled = False
    StopGoOnCmd.Enabled = False
    GoOnCmd.Enabled = False
    pGoOnCmd.Enabled = False
    BeginCmd.Enabled = False
'    StopNow = False
End Sub

Private Sub StopGoOnCmd_Click()
'    YTimer.Enabled = False
'    XTimer.Enabled = False
    Timer.Enabled = False
    StopGoOnCmd.Enabled = False
    GoOnCmd.Enabled = True
    CircleGoOn = False
    If (bDrawCircle) Then
        CircleGoOn = False
    End If
'    StopNow = True
End Sub

Private Sub Timer_Beep_Timer()
    Beep
End Sub

Private Sub Timer_Timer()
'    Dim iTag As Integer
'    Dim dx, dy As Double
'    Dim tx, ty, inc1, inc2, d, curx, cury As Long
'    'Dim scaleDistance As Double
'    Dim XY As Long
'    Dim Dxy As Double
'
'    If (X0 = X1) And (Y1 = Y0) Then
'        Timer.Enabled = False
'        Exit Sub
'    End If
'
'    iTag = 0
'
'    'scaleDistance = Ax / Ay
'    dx = Ax * Abs(X1 - X0)
'    dy = Ay * Abs(Y1 - Y0)
'
'    If (dx < dy) Then
'        iTag = 1
'
'        XY = X1
'        X1 = Y1
'        Y1 = XY
'
'        XY = X0
'        X0 = Y0
'        Y0 = XY
'
'        Dxy = dx
'        dx = dy
'        dy = Dxy
'    End If
'
'    tx = IIf(X1 > X0, Ax, -Ax)
'    ty = IIf(Y1 > Y0, Ay, -Ay)
'
'    curx = X0
'    cury = Y0
'
'    inc1 = 2 * dy
'    inc2 = 2 * (dy - dx)
'
'    d = inc1 - dx
'
'    Do While (Abs(curx - X1) >= Ax)
'        If (d < 0) Then
'            d = d + inc1
'        Else
'            cury = cury + ty
'            d = d + inc2
'        End If
'        If (iTag) Then
'            SendOneYSignal (Sgn(ty))
'        Else
'            SendOneXSignal (Sgn(tx))
'        End If
'        curx = curx + tx
'    Loop
    
'If (Shape = 1) Then
'    If iTag Then
'        If Sgn(ty) = 1 Then
'            If (Y1 - cury) < Ay Then
'                Timer.Enabled = False
'                X0 = xPos
'                Y0 = yPos
'                Exit Sub
'            End If
'        Else
'            If (cury - Y1) < Ay Then
'                Timer.Enabled = False
'                X0 = xPos
'                Y0 = yPos
'                Exit Sub
'            End If
'        End If
'    Else
'        If Sgn(tx) = 1 Then
'            If (X1 - curx) < Ax Then
'                Timer.Enabled = False
'                X0 = xPos
'                Y0 = yPos
'                Exit Sub
'            End If
'        Else
'            If (curx - X1) < Ax Then
'                Timer.Enabled = False
'                X0 = xPos
'                Y0 = yPos
'                Exit Sub
'            End If
'        End If
'    End If

'    If (Abs(curx - X1) <= Ax) Then
'        Timer.Enabled = False
'        MsgBox "发送完毕", vbInformation, "提示"
'        Exit Sub
'    End If
    
'If (Abs(curx - X1) < Ax) Then
'    Timer.Enabled = False
'    X0 = X2 'xPos
'    Y0 = Y2 'yPos
'    Exit Sub
'End If
    bijiaoX2 = X2
    bijiaoY2 = Y2

'    If (DirectX) Then
'        If (Abs(Y2 - dY01) < Ay) Then
'            Timer.Enabled = False
'            Exit Sub
''            'StopGoOnCmd.Enabled = False
'        End If
'    End If
'
'    If (DirectY) Then
'        If (Abs(X2 - dX01) < Ax) Then
'            Timer.Enabled = False
'            Exit Sub
'            'StopGoOnCmd.Enabled = False
'        End If
'    End If

    'If Not DirectX And Not DirectY And ((Abs(X2 - dX01) < Ax) Or (Abs(Y2 - dY01) < Ay)) Then