adjustfrm.frm

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

      Caption         =   "返回"
      Height          =   375
      Left            =   8580
      TabIndex        =   0
      Top             =   6720
      Width           =   915
   End
   Begin VB.Label Label1 
      BackColor       =   &H8000000B&
      Caption         =   "数控切割控制系统"
      BeginProperty Font 
         Name            =   "隶书"
         Size            =   24
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00C00000&
      Height          =   615
      Left            =   2340
      TabIndex        =   19
      Top             =   120
      Width           =   4095
   End
   Begin VB.Label Label2 
      Caption         =   "校准"
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   15.75
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   435
      Left            =   420
      TabIndex        =   1
      Top             =   900
      Width           =   735
   End
End
Attribute VB_Name = "AdjustFrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim xTimes As Integer
Dim yTimes As Integer
Dim xDirection As Integer
Dim yDirection As Integer

Private Sub AdjustXCmd_Click()
    AdjustXCmd.Enabled = False
    AdjustXTimer.Enabled = True
    txtXDistance.Text = ""
    If OptionFront Then
        xDirection = 0
    Else
        xDirection = 1
    End If
End Sub

Private Sub adjustSaveCmd_Click()
    Dim fs As Object
    Dim A As Object
    Dim xDistance As Long
    Dim yDistance As Long
    Dim xCount As Integer
    Dim yCount As Integer
    Dim iAx As Double
    Dim iAy As Double
    Dim iAz As Double
    
    If (AdjustXCmd.Enabled = True) Or (AdjustYCmd.Enabled = True) Then
        MsgBox "请按发送按钮", vbInformation, "提示"
        Exit Sub
    End If
    
    xCount = IIf(txtXCount.Text = "", 0, txtXCount.Text)
    yCount = IIf(txtYCount.Text = "", 0, txtYCount.Text)
    
    xDistance = IIf(txtXDistance.Text = "", 0, txtXDistance.Text)
    yDistance = IIf(txtYDistance.Text = "", 0, txtYDistance.Text)
    
    If (xCount = 0) And (yCount = 0) Then
        MsgBox "发送信号个数不能为0或者空", vbInformation, "提示"
    End If
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    If Not (fs.FileExists(App.Path + "\设置文件\校准.txt")) Then
        If (xCount = 0) Or (yCount = 0) Then
            MsgBox "X轴或Y轴发送信号个数不能为0或者空", vbInformation, "提示"
            Exit Sub
        End If
        
        iAx = xDistance / xCount
        iAy = yDistance / yCount
        
        Ax = iAx
        Ay = iAy
       
        Set A = fs.CreateTextFile(App.Path + "\设置文件\校准.txt", True)
        A.WriteLine ("[X]")
        A.WriteLine ("Ax = " & Format(iAx, "###0.000"))
        A.WriteLine ("[Y]")
        A.WriteLine ("Ay = " & Format(iAy, "###0.000"))
        A.WriteLine ("[Z]")
        A.WriteLine ("Az = " & Format(0, "###0.000"))
        A.Close
    Else
        ReadAdjustReal
        If (xCount = 0) And (yCount = 0) Then
            MsgBox "X轴和Y轴发送信号个数不能都为0或者空", vbInformation, "提示"
            Exit Sub
        End If
        If (txtXDistance.Text = "") Or (xCount = 0) Then
            iAx = Ax
        Else
            iAx = xDistance / xCount
        End If
        If (txtYDistance.Text = "") Or (yCount = 0) Then
            iAy = Ay
        Else
            iAy = yDistance / yCount
        End If
        
        iAz = Az
        
        Set A = fs.CreateTextFile(App.Path + "\设置文件\校准.txt", True)
        A.WriteLine ("[X]")
        'iAx = xDistance / xCount
        'iAy = yDistance / yCount
        A.WriteLine ("Ax = " & Format(iAx, "###0.000"))
        A.WriteLine ("[Y]")
        A.WriteLine ("Ay = " & Format(iAy, "###0.000"))
        A.WriteLine ("[Z]")
        A.WriteLine ("Az = " & Format(iAz, "###0.000"))
        A.Close
    End If
    adjustSaveCmd.Enabled = False
End Sub

Private Sub AdjustXTimer_Timer()
    If (xDirection = 0) Then
        WritePortDirect 1, 1
        Result = WriteOneSignal(1, 1)
    Else
        WritePortDirect 1, 2
        Result = WriteOneSignal(1, 1)
    End If

    Call Judge
'    Call SendXSignal(1)
    xTimes = xTimes + 1
    If (xTimes = txtXCount.Text) Then
        AdjustXTimer.Enabled = False
        xTimes = 0
        MsgBox "X轴发送完毕!", vbInformation, "提示"
    End If
End Sub

Private Sub AdjustYCmd_Click()
    AdjustYCmd.Enabled = False
    AdjustYTimer.Enabled = True
    txtYDistance.Text = ""
    If OptionLeft Then
        yDirection = 0
    Else
        yDirection = 1
    End If
End Sub

Private Sub AdjustYTimer_Timer()
    If (yDirection = 0) Then
        WritePortDirect 2, 1
        Result = WriteOneSignal(2, 1)
    Else
        WritePortDirect 2, 2
        Result = WriteOneSignal(2, 1)
    End If

'    Call SendXSignal(1)
    Call Judge
    
    yTimes = yTimes + 1
    If (yTimes = txtYCount.Text) Then
        AdjustYTimer.Enabled = False
        yTimes = 0
        MsgBox "Y轴发送完毕!", vbInformation, "提示"
    End If
End Sub

Private Sub BackCmd_Click()
    Unload Me
    MainFrm.Show vbModal
End Sub

Private Sub Process_Key(KeyCode As Integer, Shift As Integer)
    If (KeyCode = vbKeyBack) And (Shift = 4) Then
        Call BackCmd_Click
    End If
End Sub

Private Sub BackCmd_KeyDown(KeyCode As Integer, Shift As Integer)
    Call Process_Key(KeyCode, Shift)
End Sub

Private Sub Form_Activate()
    txtXCount.SetFocus
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Call Process_Key(KeyCode, Shift)
End Sub

Private Sub Form_Load()
    xTimes = 0
    yTimes = 0
End Sub

Private Sub Timer_Beep_Timer()
    Beep
End Sub

Private Sub txtXCount_KeyUp(KeyCode As Integer, Shift As Integer)
    If (Trim(txtXCount.Text) <> "") Then
        AdjustXCmd.Enabled = True
    Else
        AdjustXCmd.Enabled = False
    End If
End Sub

Private Sub txtXCount_KeyPress(KeyAscii As Integer)
    If ((KeyAscii < Asc(0)) Or (KeyAscii > Asc(9))) And (KeyAscii <> 8) And (KeyAscii <> 46) Then
        KeyAscii = 0
    End If
End Sub

Private Sub txtXDistance_KeyPress(KeyAscii As Integer)
    If ((KeyAscii < Asc(0)) Or (KeyAscii > Asc(9))) And (KeyAscii <> 8) And (KeyAscii <> 46) Then
        KeyAscii = 0
    End If
End Sub

Private Sub txtXDistance_KeyUp(KeyCode As Integer, Shift As Integer)
    If (Trim(txtXDistance.Text) <> "") Then
        adjustSaveCmd.Enabled = True
    Else
        If (Trim(txtYDistance.Text) = "") Then
            adjustSaveCmd.Enabled = False
        End If
    End If
End Sub

Private Sub txtYCount_KeyPress(KeyAscii As Integer)
    If ((KeyAscii < Asc(0)) Or (KeyAscii > Asc(9))) And (KeyAscii <> 8) And (KeyAscii <> 46) Then
        KeyAscii = 0
    End If
End Sub

Private Sub txtYCount_KeyUp(KeyCode As Integer, Shift As Integer)
    If (Trim(txtYCount.Text) <> "") Then
        AdjustYCmd.Enabled = True
    Else
        AdjustYCmd.Enabled = False
    End If
End Sub

Private Sub txtYDistance_KeyPress(KeyAscii As Integer)
    If ((KeyAscii < Asc(0)) Or (KeyAscii > Asc(9))) And (KeyAscii <> 8) And (KeyAscii <> 46) Then
        KeyAscii = 0
    End If
End Sub

Private Sub txtYDistance_KeyUp(KeyCode As Integer, Shift As Integer)
    If (Trim(txtYDistance.Text) <> "") Then
        adjustSaveCmd.Enabled = True
    Else
        If (Trim(txtXDistance.Text) = "") Then
            adjustSaveCmd.Enabled = False
        End If
    End If
End Sub

Private Sub Judge()
    If (Result = 2) And AdjustXTimer.Enabled Then
        AdjustXTimer.Enabled = False
        MsgBox "X轴到头！返回", vbInformation, "提示"
        Unload Me
        MainFrm.Show vbModal
        Exit Sub
    End If
    
    If (Result = 3) And AdjustYTimer.Enabled Then
        AdjustYTimer.Enabled = False
        MsgBox "Y轴到头！返回", vbInformation, "提示"
        Unload Me
        MainFrm.Show vbModal
        Exit Sub
    End If
    
    If (Result = 1) Then
        AdjustXTimer.Enabled = False
        AdjustYTimer.Enabled = False
        Timer_Beep.Enabled = True
        MsgBox "出现故障", vbInformation, "提示"
        Timer_Beep.Enabled = False
        Unload Me
        MainFrm.Show vbModal
        Exit Sub
    End If
End Sub