globalmdl.bas

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

Attribute VB_Name = "GlobalMdl"
Option Explicit
'运动形式(1--直线，2--顺时划圆，3--逆时划圆)
Global G0 As Integer
'单位(0--英制，英寸，1--毫米)
Global G7 As Integer
'坐标(0--绝对坐标，1--相对坐标)
Global G9 As Integer

'状态，辅助功能(0--暂停，1--正常，2--程序停止)
Global M As Integer

'速度
Global F As Double
'x轴速度
Global Fx As Double
'y轴速度
Global Fy As Double

'起始坐标,x轴
Global X0 As Double
'起始坐标,y轴
Global Y0 As Double
'终止坐标,x轴
Global X1 As Double
'终止坐标,y轴
Global Y1 As Double
'当前坐标,x轴
Global X2 As Double
'当前坐标,y轴
Global Y2 As Double

'圆心距离起始坐标的x距离
Global I As Double
'圆心距离起始坐标的y距离
Global J As Double
'圆半径
Global r As Double

'圆的单位直线的角度
Global perAngle As Double

Global PrgFileLineNumber As Integer

'直线多头的速度
Global DirectMultiSpeed As Double
'直线多头的长度
Global DirectMultiLength As Double

Global FFBQuick As Long
Global FFBSlow As Long

'手动移动时的左右速度
Global manulLRSpeed As Long

Global Ax As Double    'x轴的校准系数
Global Ay As Double    'y轴的校准系数
Global Az As Double    'z轴的校准系数

Global ProgramFileName As String  '控制程序的路径及文件名

Global Pi As Double

Global Result As Integer

Public Function AtoL(sNumber As String) As Long
    Dim lNum As Long
    Dim sLen As Integer
    Dim i1 As Integer
    Dim sSrc As String
    
    sSrc = sNumber
    lNum = 0
    sLen = Len(sNumber)
    For i1 = 1 To sLen - 1
        lNum = lNum * 10 + Asc(Mid(sSrc, i1, 1)) - 48
    Next
    
    AtoL = lNum
End Function

Public Sub SendOneXSignal(iDirect As Integer)
    
End Sub

Public Sub SendOneYSignal(iDirect As Integer)
    
End Sub

Public Function ReadRightString(sOneLine As String) As String
    Dim RightStr As String
    
    RightStr = Trim(Right(sOneLine, Len(sOneLine) - InStr(sOneLine, "=")))
    ReadRightString = RightStr
End Function

Public Function ReadAdjustReal() As Boolean
    Dim fs As Object
    Dim A As Object
    Dim Mystr As String
    Dim sXStr As String
    Dim sYStr As String
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    If Not (fs.FileExists(App.Path + "\设置文件\校准.txt")) Then
        ReadAdjustReal = False
        Exit Function
    Else
        Close #1
        Open App.Path + "\设置文件\校准.txt" For Input As #1
            Do While Not EOF(1)
                Input #1, Mystr
                If (Mystr = "[X]") Then
                    If Not EOF(1) Then
                        Input #1, sXStr
                        If (sXStr <> "") Then
                            Ax = ReadRightString(sXStr)
                        End If
                    Else
                        ReadAdjustReal = False
                        Close #1
                        Exit Function
                    End If
                End If
                If (Mystr = "[Y]") Then
                    If Not EOF(1) Then
                        Input #1, sYStr
                        If (sYStr <> "") Then
                            Ay = ReadRightString(sYStr)
                        End If
                    Else
                        ReadAdjustReal = False
                        Close #1
                        Exit Function
                    End If
                End If
                If (Mystr = "[Z]") Then
                    If Not EOF(1) Then
                        Input #1, sYStr
                        If (sYStr <> "") Then
                            Az = ReadRightString(sYStr)
                        End If
                    Else
                        ReadAdjustReal = False
                        Close #1
                        Exit Function
                    End If
                End If
            Loop
        Close #1
        ReadAdjustReal = True
    End If
End Function

Public Function DivideLine(sStr As String) As Boolean
    Dim lttlStr As String
    Dim dStr As String
    Dim lenStr As Integer
    Dim i1 As Integer
    
    dStr = Trim(sStr)
    lenStr = Len(sStr)
    
    i1 = 0
    
    Do While (i1 < lenStr)
        lttlStr = GetOneSubStr(dStr)
        DivideLine = getValue(lttlStr)
        If Not DivideLine Then
            Exit Do
        End If
        i1 = i1 + Len(lttlStr) + 1
        dStr = Trim(Right(dStr, Len(dStr) - Len(lttlStr)))
    Loop
End Function

Public Sub SendXSignal(Direction As Integer)
    'Direction(1 -- 向左(x-)，2 -- 向右(x+))
    Dim iCount As Long
    Dim i1 As Integer
     
End Sub

Public Sub SendYSignal(Direction As Integer)
    'Direction(1 -- 向前(y+)，2 -- 向后(y-))
    Dim iCount As Long
    Dim i1 As Integer
    
'    iCount = fFy / Ay
'
'    For i1 = 1 To iCount
'           PauseTime = 5   ' 设置暂停时间。
'   Start = Timer   ' 设置开始暂停的时刻。
'   Do While Timer < Start + PauseTime
'      DoEvents   ' 将控制让给其他程序。
'   Loop
'   Finish = Timer   ' 设置结束时刻。
'   TotalTime = Finish - Start   ' 计算总时间。
'
'    Next
End Sub

Public Function GetOneSubStr(sStr As String) As String
    Dim sTmp As String
    Dim Position As Integer
    
    Position = InStr(sStr, " ")
    If (Position = 0) Then
        sTmp = sStr
    Else
        sTmp = Left(sStr, Position)
    End If
    GetOneSubStr = Trim(sTmp)
End Function

Public Function getValue(sStr) As Boolean
    Dim FirstChr As String
    Dim OtherStr As String
    
    FirstChr = UCase(Left(sStr, 1))
    getValue = True
    On Error GoTo errHandler
    If (FirstChr = "G") Then
        OtherStr = Right(sStr, Len(sStr) - 1)
        If (Left(OtherStr, 1) = "0") Then
            G0 = Right(OtherStr, Len(OtherStr) - 1)
        Else
            If (Left(OtherStr, 1) = "7") Then
                G7 = Right(OtherStr, Len(OtherStr) - 1)
            Else
                If (Left(OtherStr, 1) = "9") Then
                    G9 = Right(OtherStr, Len(OtherStr) - 1)
                End If
            End If
        End If
    Else
        If (FirstChr = "M") Then
            OtherStr = Right(sStr, Len(sStr) - 1)
            M = Right(OtherStr, Len(OtherStr) - 1)
        Else
            If (FirstChr = "F") Then
                F = Right(sStr, Len(sStr) - 1)
            Else
                If (FirstChr = "X") Then
                    If (G9 = 0) Then
                        X1 = Right(sStr, Len(sStr) - 1)
                    End If
                    If (G9 = 1) And (G7 = 1) Then
                        X1 = X0 + CInt(Right(sStr, Len(sStr) - 1))
                    End If
                    If (G7 = 1) And (G7 = 0) Then
                        X1 = X0 + 25.4 * CInt(Right(sStr, Len(sStr) - 1))
                    End If
                    If (G7 = 0) And (G9 = 0) Then
                        X1 = 25.4 * CInt(Right(sStr, Len(sStr) - 1))
                    End If
                Else
                    If (FirstChr = "Y") Then
                        If (G9 = 0) Then
                            Y1 = Right(sStr, Len(sStr) - 1)
                        End If
                        If (G9 = 1) And (G7 = 1) Then
                            Y1 = Y0 + CInt(Right(sStr, Len(sStr) - 1))
                        End If
                        If (G9 = 1) And (G7 = 0) Then
                            Y1 = Y0 + 25.4 * CInt(Right(sStr, Len(sStr) - 1))
                        End If
                        If (G7 = 0) And (G9 = 0) Then
                            Y1 = 25.4 * CInt(Right(sStr, Len(sStr) - 1))
                        End If
                    Else
                        If (FirstChr = "I") Then
                            I = Right(sStr, Len(sStr) - 1)
                            r = 0
                        Else
                            If (FirstChr = "J") Then
                                J = Right(sStr, Len(sStr) - 1)
                                r = 0
                            Else
                                If (FirstChr = "R") Then
                                    r = Right(sStr, Len(sStr) - 1)
                                    I = 0
                                    J = 0
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If

'errHandler:
'    If Err.Number = 13 Then
'        getValue = False
'        MsgBox "代码文件有错", vbInformation, "提示"
'    End If
errHandler:
    If Err.Number = 13 Then
        getValue = False
    End If
End Function

'Public Function Access_LineProgram() As Integer
'    If (M = 0) Or (M = 2) Then
'        Access_LineProgram = M
'        Exit Function
'    End If
'    If (G0 = 1) Then
'        Fx = F * (X1 - X0) / Sqr((X1 - X0) * (X1 - X0) + (Y1 - Y0) * (Y1 - Y0))
'        Fy = F * (Y1 - Y0) / Sqr((X1 - X0) * (X1 - X0) + (Y1 - Y0) * (Y1 - Y0))
'        Call SendXSignal(Fx)
'        Call SendYSignal(Fy)
'    End If
'    If (G0 = 2) Then
'
'    End If
'End Function

'Public Sub SendLineSignal(dFx As Double, dFy As Double)
'    Dim xInterval As Integer
'    Dim yInterval As Integer
'
'    xInterval = CInt(Ax / dFx)
'    yInterval = CInt(Ay / dFy)
'End Sub

Public Sub WritePortDirect(OneObject As Integer, iDirect As Integer)
    'OneObject (1 -- 主机，2--辅机，3--上下1，4--上下2)
    'iDirect (1 -- 顺时针,2 -- 逆时针)
    Dim Direct As Integer
    
    If (iDirect = 1) Then
        Direct = 1
    Else
        Direct = 2
    End If
    
    Select Case OneObject
        Case 1
            Direct = 2 * 2 * 2 * 2 * 2 * 2 * Direct
        Case 2
            Direct = 2 * 2 * 2 * 2 * Direct
        Case 3
            Direct = 2 * 2 * Direct
        Case 4
            Direct = Direct
        Case Else
    End Select
    
    DlPortWritePortUshort &H3F0, Direct
    DlPortWritePortUshort &H3F1, Direct
End Sub

Public Function WriteOneSignal(OneObject As Integer, iDirect As Integer) As Integer
    'iDirect(1 -- 前进,2 -- 停止)
    Dim GoOn As Integer
    Dim StopInfo As Integer
    
    Dim PortInfo As Byte  '3F3口的读入数据
    
    StopInfo = 1
    If (iDirect = 1) Then
        GoOn = 2
    Else
        GoOn = 1
    End If
'    DlPortWritePortUshort &H3AA, GoOn
    'OneObject (1 -- 主机，2--辅机，3--上下1，4--上下2)
    'iDirect (1 -- 顺时针,2 -- 逆时针)
'    Dim Direct As Integer
    
'    If (iDirect = 1) Then
'        Direct = 1
'    Else
'        Direct = 2
'    End If
    
    Select Case OneObject
        Case 1
            GoOn = 4 * 4 * 4 * GoOn
            StopInfo = 4 * 4 * 4 * StopInfo
        Case 2
            GoOn = 4 * 4 * GoOn
            StopInfo = 4 * 4 * StopInfo
        Case 3
            GoOn = 4 * GoOn
            StopInfo = 4 * StopInfo
        Case 4
            GoOn = GoOn
            StopInfo = StopInfo
        Case Else
    End Select
    
    DlPortWritePortUshort &H3F2, GoOn
    DlPortWritePortUshort &H3F2, StopInfo
    
    WriteOneSignal = 0 '正常
    
    PortInfo = DlPortReadPortUchar(&H3F3)
    
    If (PortInfo And 2) = 2 Then
        WriteOneSignal = 2 'X轴限位
        Exit Function
    End If
    
    If (PortInfo And 4) = 4 Then
        WriteOneSignal = 3 'Y轴限位
        Exit Function
    End If
    
    If (PortInfo And 1) = 1 Then
        WriteOneSignal = 1 '故障报警
        Exit Function
    End If
End Function