modfuntion.bas

自动回传考勤数据程序,小程序!大作用!可供大家参考一下!

Attribute VB_Name = "ModFuntion"
Option Explicit
Private portn As Integer, i As Integer, j As Integer, k As Integer, recno As Integer     'availble com port
Private zd As String, zt As String, ztemp As String, zmsgstr As String
Dim zif As Integer
'for ceciept data
Private byt(16), z16 As String
Private av As Variant

'for send data
Private ByteArray(16) As Byte
Private Intarray(16) As Integer

'for time judge
Private stime, ptime, etime
Public Resend As Integer
Public Const RecordLen = 12

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'for log
'Private fs As Scripting.FileSystemObject
'Private txt As TextStream

  
'判断输入的是否汉字
Public Function IfChn(InText As String) As Boolean
On Error GoTo ErrorHandler

    Static SStr As String
    Dim i As Integer
    Dim TempFile, TempFileBinary, tmpStr As String
    Dim TotalNum, L As Long
    TotalNum = 0
    L = Len(InText)
    For i = 1 To L
        tmpStr = StrConv(Mid$(InText, i, 1), vbWide)
        If Asc(Mid$(InText, i, 1)) < 0 Then
            TotalNum = TotalNum + 1
            SStr = InText
        Else
            IfChn = False   '写入的不是汉字！
            InText = Left(InText, Len(InText) - 1)
            Exit Function
        End If
    Next i
'    LblNum.Caption = Str$(TotalNum) + "个汉字"
'    TempFile = App.Path + "\" + "TempSrc.txt"
'    'TempFileBinary = App.Path + "\" + "TempSrcBinary.txt"
'    Open TempFile For Output As #1
'    Print #1, SrcTxt.Text
'    Close #1
    IfChn = True
Exit Function
ErrorHandler:
IfChn = 44
End Function
'　　在实例中选用了UCDOS 5.0汉字系统中的
'16 点阵字库Hzk16作为提取汉字字模的标准字库?
Public Function GetChnModel(InText As String, RetunArray() As Byte) As Boolean
On Error GoTo ErrorHandler

    Dim TempSrcFile As String
    Dim TempDestFile As String
    Dim TempFile As String
    Dim HzFile As String
    Dim To61202(32) As Integer
    Dim P(1 To 2) As Byte
    Dim C1, C2
    Dim rec As Integer
    Dim Location As Long '汉字在字库中的位置
    Dim Hz(0 To 31) As Byte '转换完的32字节的字模数据
    Dim Buf1() As Byte '暂存转换过程中的32字节字模数据
    Dim HzAll() As Byte  '存放全部字模数据的动态数组
    Dim LoopAll As Integer
    Dim bit, k2, k3 As Byte
    Dim i, j, i1, k, k1, k4, k5, k6 As Integer
    Dim Flag As Integer
    Dim HzNum As Long 'Hui
    Dim FreeFileNo As Integer
'    DestTxt.Text = "" 'DestTxt是目标文本框，存放转换后的16进制数据

'首先判断写入的是不是汉字!
    GetChnModel = True
    If IfChn(InText) = False Then
        GetChnModel = False
        Exit Function
    End If
    Flag = 0
'    TempDestFile$ = App.Path + "\" + "TempDest.txt"
    TempFile = App.Path + "\" + "TempSrc.txt"
'    If FileExists(TempDestFile$) Then Kill TempDestFile 'FileExists是一个检查文件是否存在的自定义函数
'    If SrcTxt.Text = "" Then '汉字输入框内无汉字则退出
'        MsgBox "没有可以转换的字模源文件！"
'        Exit Function
'    End If
    
    HzNum = Len(InText) '获得汉字的个数
    ReDim HzAll(0 To HzNum * 32 - 1) '重新定义动态数组的上界
    FreeFileNo = FreeFile()
    Open TempFile For Output As #FreeFileNo
    Print #FreeFileNo, InText
    Close #FreeFileNo
    For LoopAll = 0 To HzNum - 1
            FreeFileNo = FreeFile()
            Open TempFile For Binary Access Read As #FreeFileNo '按二进制方式打开
            Get #FreeFileNo, 2 * LoopAll + 1, P
            Close #FreeFileNo
            C1 = CStr(P(1)) - &HA1 '区内码
            C2 = CStr(P(2)) - &HA1 '位内码
            rec = C1 * 94 + C2
            Location = CLng(rec) * 32 + 1 '该汉字在16*16点阵字库中字模第一个字节的位置
            HzFile = App.Path + "\" + "hzk16"
            FreeFileNo = FreeFile()
            Open HzFile For Binary Access Read As #FreeFileNo '读取该汉字在16点阵字库中的原始字模
            
            Get #FreeFileNo, Location, Hz
            Close #FreeFileNo
            '以下是将UCDOS字库的存储格式调整为HD61202的规范格式
            ReDim Buf1(0 To 31)
            For j = 0 To 3
                If j = 0 Then k4 = 14
                If j = 1 Then k4 = 15
                If j = 2 Then k4 = 30
                If j = 3 Then k4 = 31
                For k = 0 To 7
                    bit = &H80
                    bit = byteRight((bit), (k))
                    For i = 0 To 7
                    k2 = byteLeft(Buf1(j * 8 + k), 1) '整个流程是由低位向高位移动,最后凑成一个字节
                    k3 = byteRight((Hz(k4 - i * 2) And bit), 7 - k) '将字节中的某位移到最低位
                    k3 = k3 And &H1 '屏蔽掉其余7位
                    Buf1(j * 8 + k) = k2 Or k3
                    Next i
                Next k
            Next j
            For i1 = 0 To 31 '将调整后的汉字字模再装入原数组
                Hz(i1) = Buf1(i1)
                HzAll(LoopAll * 32 + i1) = Buf1(i1)
            Next
    Next LoopAll
    RetunArray = HzAll
Exit Function
ErrorHandler:
GetChnModel = 44
End Function
Public Function byteRight(byte1 As Byte, n As Integer) As Byte '将byte1右移n位
On Error GoTo ErrorHandler

    Dim TemVar As Byte '临时变量
    Dim TemVar1 As Byte '临时变量
    Dim X, Y As Integer
    TemVar = byte1
    For X = 1 To n '移多少位就循环多少次
    For Y = 1 To 8 '从第一位(右边第一位)开始循环右移
    Select Case Y
    Case 1
    If (TemVar And &H1) = &H1 Then '如果临时变量TemVar的第一位是1,
    TemVar1 = &H1 '则将临时变量TemVar1置1,
    Else
    TemVar1 = &H0 '则将临时变量TemVar1置0,
    End If
    Case 2
    If (TemVar And &H2) = &H2 Then '如果临时变量TemVar的第二位是1,
    TemVar = TemVar Or &H1 '则将其第一位置1(其它位不变),
    Else
    TemVar = TemVar And &HFE '反之将第一位置0(其它位不变)
    End If
    Case 3
    If (TemVar And &H4) = &H4 Then '操作与上面相同
    TemVar = TemVar Or &H2
    Else
    TemVar = TemVar And &HFD
    End If
    Case 4
    If (TemVar And &H8) = &H8 Then
    TemVar = TemVar Or &H4
    Else
    TemVar = TemVar And &HFB
    End If
    Case 5
    If (TemVar And &H10) = &H10 Then
    TemVar = TemVar Or &H8
    Else
    TemVar = TemVar And &HF7
    End If
    Case 6
    If (TemVar And &H20) = &H20 Then
    TemVar = TemVar Or &H10
    Else
    TemVar = TemVar And &HEF
    End If
    Case 7
    If (TemVar And &H40) = &H40 Then
    TemVar = TemVar Or &H20
    Else
    TemVar = TemVar And &HDF
    End If
    Case 8
    If (TemVar And &H80) = &H80 Then
    TemVar = TemVar Or &H40
    Else
    TemVar = TemVar And &HBF
    End If
    If TemVar1 = &H1 Then '移完第八位后,如果TemVar1是1(即第一位是1)
    TemVar = TemVar Or &H80 '则将TemVar的第八位置1
    Else
    TemVar = TemVar And &H7F '反之置0
    End If
    End Select
    Next Y
    Next X
    byteRight = TemVar '将TemVar的值返回给函数名
Exit Function
ErrorHandler:
byteRight = 44
End Function
Public Function byteLeft(byte1 As Byte, n As Integer) As Byte '将byte1左移n位
On Error GoTo ErrorHandler

    Dim TemVar As Byte '临时变量
    Dim TemVar1 As Byte '临时变量
    Dim X, Y As Integer
    TemVar = byte1
    For X = 1 To n '移多少位就循环多少次
    For Y = 1 To 8 '从第8位(右边第一位)开始循环右移
    Select Case Y
    Case 1
        If (TemVar And &H80) = &H80 Then '如果临时变量TemVar的第8位是1,
        TemVar1 = &H1 '则将临时变量TemVar1置1,
        Else
        TemVar1 = &H0 '则将临时变量TemVar1置0,
        End If
    Case 2
         If (TemVar And &H40) = &H40 Then
            TemVar = TemVar Or &H80
        Else
            TemVar = TemVar And &H7F
        End If
    Case 3
        If (TemVar And &H20) = &H20 Then
            TemVar = TemVar Or &H40
        Else
            TemVar = TemVar And &HBF
        End If
    Case 4
        If (TemVar And &H10) = &H10 Then
            TemVar = TemVar Or &H20
        Else
            TemVar = TemVar And &HDF
        End If
    Case 5
        If (TemVar And &H8) = &H8 Then
            TemVar = TemVar Or &H10
        Else
            TemVar = TemVar And &HEF
        End If
    Case 6
        If (TemVar And &H4) = &H4 Then '操作与上面相同
            TemVar = TemVar Or &H8
        Else
            TemVar = TemVar And &HF7
        End If
    Case 7
        If (TemVar And &H2) = &H2 Then '如果临时变量TemVar的第二位是1,
            TemVar = TemVar Or &H4 '则将其第3位置1(其它位不变),
        Else
            TemVar = TemVar And &HFB '反之将第3位置0(其它位不变)
        End If
    Case 8
        If (TemVar And &H1) = &H1 Then '如果临时变量TemVar的第1位是1,
            TemVar = TemVar Or &H2 '则将其第2位置1(其它位不变),
        Else
            TemVar = TemVar And &HFD '反之将第2位置0(其它位不变)
        End If
        If TemVar1 = &H1 Then '移完第八位后,如果TemVar1是1(即第8位是1)
        TemVar = TemVar Or &H1 '则将TemVar的第八位置1
        Else
        TemVar = TemVar And &HFE '反之置0
        End If
    End Select
    Next Y
    Next X
    byteLeft = TemVar '将TemVar的值返回给函数名

Exit Function
ErrorHandler:
byteLeft = 44
End Function
Public Function OpenCom(MSComm As MSComm, ComPortNo As Integer, ComPortSpeed As Long, P As String) As Integer
On Error Resume Next

    
    If MSComm.PortOpen = True Then '判断通信口是否打开
        If ComPortNo <> MSComm.CommPort Then
           MSComm.PortOpen = False       '关闭通信口
        End If
    End If
    
    MSComm.Settings = ComPortSpeed & "," & P & ",8,1"  '设置通信口参数
    MSComm.InputMode = 1            '设置接收数据模式为二进制形式
  

    MSComm.InputLen = 1             '设置Input 一次从接收缓冲读取字节数为1
  

    MSComm.SThreshold = 0           'comEvSend 事件无效
  

    MSComm.RThreshold = 0           '设置接收一个字节产生OnComm事件

    If MSComm.PortOpen = False Then '判断通信口是否打开
        MSComm.InBufferSize = 1024       '设置MSComm接收缓冲区为512字节
        MSComm.OutBufferSize = 512      '设置MSComm发送缓冲区为512字节
        MSComm.CommPort = ComPortNo             '使用COM
        MSComm.PortOpen = True       '打开通信口
    End If
    
    If MSComm.PortOpen Then     '判断通信口是否打开
       OpenCom = 8
    Else
        OpenCom = 1       '"通信口连接超时！ 请检查"
    End If
End Function

Public Function FoundMac(MSComm As MSComm, ComPortNo As Integer, ComPortSpeed As Long, MachineNo As Integer, FailResendTimes As Integer, Optional MachineType As Integer) As Integer
On Error GoTo ErrorHandler

    Dim OutChar(0) As Byte
    Dim OutCharS(1) As Byte
    Dim av As Variant
    Dim byt(1) As Integer
    Dim tmpT
    If MachineNo > 255 Then
        FoundMac = 256
        Exit Function
    End If
    If MSComm.PortOpen = False Then
        zif = OpenCom(MSComm, ComPortNo, ComPortSpeed, "M")
    End If
    If MSComm.PortOpen = True Then
        For i = 0 To FailResendTimes   '若找不到卡钟，则重发
            If i > 0 Then
                Sleep (10)
            End If
            MSComm.InBufferCount = 0
            MSComm.OutBufferCount = 0
            OutChar(0) = MachineNo
            MSComm.Settings = ComPortSpeed & ",M,8,1"  '设置通信口参数
            MSComm.Output = OutChar

            Sleep (2)
            If MachineNo < 255 Then