module1.bas

VB写的通过串口与考勤机连接通讯的程序

Attribute VB_Name = "Module1"
'
'
'------------------------ By 陈锐 ------------------------------------
'如果你要在Internet或BBS上转贴程序,请通知我本人知道
'请参观我的网址 http://www.nease.net/~blackcat
'我的EMail是[e-mail]或[e-mail]
'
'这是一个将图标添加到WIN95的TaskBar的程序，同其他用VB编写的程序不同，这个
'程序可以响应鼠标事件，（其它的很多程序只能将一个图标放在TaskBar上）

Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hicon As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As Any) As Long
Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Recchar() As Byte
Public ChuShi As Boolean
Public adoCon As New ADODB.Connection
Public adoRs As New ADODB.Recordset
Declare Function GetTickCount Lib "kernel32" () As Long
Public lNum As Integer
Public Type POINTAPI
    x As Long
    y As Long
End Type

Public Type NOTIFYICONDATA
    cbSize As Long                   '结构的长度
    hwnd As Long                     '消息接收窗口的句柄
    uID As Long                      '图标的标识
    uFlags As Long                   '设置参数
    uCallbackMessage As Long         '回调消息的值
    hicon As Long                    '图标句柄
    szTip As String * 64             '提示字符串
End Type

Public Const NIM_ADD = 0             '添加图标
Public Const NIM_MODIFY = 1          '修改图标
Public Const NIM_DELETE = 2          '删除图标

Public Const NIF_MESSAGE = 1         '当有鼠标事件发生时产生消息
Public Const NIF_ICON = 2            '
Public Const NIF_TIP = 4             '图标有提示字符串


Public Const WM_LBUTTONDOWN = &H201
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_USER = &H400
Public Const WM_NOTIFYICON = WM_USER + &H100
Public Const WM_COMMAND = &H111
Public Const WM_DESTROY = &H2
Public Const WM_DRAWITEM = &H2B
Public Const WM_INITDIALOG = &H110
Public Const WM_PAINT = &HF
Public Const WM_MENUSELECT = &H11F

Public Const GWL_WNDPROC = (-4) '替换窗口处理函数

Dim pmenu As Long
Dim submenu As Long

Global lproc As Long
Function CMenu() As Boolean
'这个函数获得Form1的子菜单
  Dim l As Long
  Dim l1 As Long
  
  pmenu = GetMenu(Form1.hwnd)
  submenu = GetSubMenu(pmenu, 0)
  If submenu Then
    CMenu = True
  Else
    CMenu = False
  End If
End Function
Function Icon_Del(ihwnd As Long) As Long
  Dim ano As NOTIFYICONDATA
  Dim l As Long
  
  ano.hwnd = ihwnd
  ano.uID = 0
  ano.cbSize = Len(ano)
  '删除图标
  Icon_Del = Shell_NotifyIcon(NIM_DELETE, ano)
End Function
'这个函数接收图标句柄和窗口句柄并且新建图标
Function Icon_Add(ihwnd As Long, hicon As Long) As Long
  Dim ano As NOTIFYICONDATA
  Dim astr As String
  
  '为图标添加提示行
'  astr = LTrim$(InputBox$("Input the tips you wanted to add."))
  'ano.szTip = astr + Chr$(0)
  ano.szTip = "蓝牙考勤系统" + Chr$(0)
  '设置消息接收窗口
  ano.hwnd = ihwnd
  ano.uID = 0
  '图标有提示并且可以发送消息
  ano.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
  ano.hicon = hicon
  ano.cbSize = Len(ano)
  '将图标的回调消息设置为WM_NOTIFYICON，当在图标区域有鼠标消息，系统就会向
  '消息接收窗口发送WM_NOTIFYICON消息。
  ano.uCallbackMessage = WM_NOTIFYICON
  Icon_Add = Shell_NotifyIcon(NIM_ADD, ano)
End Function

Function DialogProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'该函数为Form2的窗口处理函数。
  Dim l As Long
  Dim l1 As Long
  Dim po As POINTAPI
  
  Select Case uMsg
    Case WM_INITDIALOG
    Case WM_DESTROY
    Case WM_COMMAND
    Case WM_DRAWITEM
    Case WM_NOTIFYICON  '有鼠标事件产生
      Select Case lParam
        Case WM_LBUTTONDOWN     '按下鼠标左键
          '提示是否删除图标
'          l = MsgBox("Delete icon?", vbYesNo)
'          If l = vbYes Then
'            '删除图标同时恢复窗口处理函数
'            l = Icon_Del(hwnd)
'            l = SetWindowLong(Form2.hwnd, GWL_WNDPROC, lproc)
'            Form1.Show
'          Else
'          End If
              If submenu Then
            l = GetCursorPos(po)        '获的光标位置
            '在光标位置处弹出菜单
            l1 = TrackPopupMenu(submenu, (TPM_LEFTALIGN Or TPM_RIGHTBUTTON), po.x, po.y, 0, Form1.hwnd, vbNull)
          End If
        Case WM_RBUTTONDOWN     '按下鼠标右键弹出菜单
          If submenu Then
            l = GetCursorPos(po)        '获的光标位置
            '在光标位置处弹出菜单
            l1 = TrackPopupMenu(submenu, (TPM_LEFTALIGN Or TPM_RIGHTBUTTON), po.x, po.y, 0, Form1.hwnd, vbNull)
          End If
        Case Else
      End Select
    Case Else
      DialogProc = False
  End Select
  DialogProc = True
End Function
Public Function RtnStr() As String
   RtnStr = "Provider = SQLOLEDB;" + ConStr
End Function
Public Function ConStr() As String
 ConStr = "Integrated security=sspi;user id=sa;initial catalog=cclanya;data source=www-qy9v9b4wl3i"
End Function



Public Function Hex_D(STR As String) As String
Dim StrDate(1 To 16) As String
Dim J, I As Integer
Dim Sum, SumJ As Integer

For J = 1 To Len(STR)
   StrDate(J) = Mid(STR, Len(STR) + 1 - J, 1)
   If Not IsNumeric(StrDate(J)) Then
      StrDate(J) = UCase(StrDate(J))
      StrDate(J) = CStr(Asc(StrDate(J)) - 55)
      
   End If
   SumJ = 1
   I = 1
  Do While I < J
    SumJ = 16 * SumJ
    I = I + 1
  Loop
  Sum = Sum + Val(StrDate(J)) * SumJ
Next J
Hex_D = CStr(Sum)
End Function




Public Sub setConnect()
On Error GoTo ErrMsg

With adoCon
   .Provider = "SQLOLEDB"
   .ConnectionString = ConStr
   .Open
End With
ErrMsg:
   If Err.Number <> 0 Then
      MsgBox "数据库连接错误:" + CStr(Err.Number) + Err.Description, vbOKOnly + vbCritical, "系统提示"
     
   End If
End Sub
Public Sub InPutKaoQin()
Dim adoCard As New ADODB.Recordset
Dim adoDay As New ADODB.Recordset
Dim TDate As Date
Dim TCardID As String
Dim adoRR As New ADODB.Recordset
Dim AdoCc As New ADODB.Connection
Dim Fid, Lid As String
Dim IID, IIC As Integer
Dim SQL As String
Dim temCardID, temDate, temHour, temMinute, temSecond As String

Set adoRs = adoCon.Execute("select LastDay from LastDay ")
If adoRs.EOF Then
   Set adoDay = adoCon.Execute("select Date from KaoQinSource order by Date")
   LastDay = adoDay!Date
   adoCon.Execute ("insert into LastDay values('" & LastDay & "')")
Else
   LastDay = adoRs!LastDay

End If


 
 


'取最后区间的日期

Set adoDay = adoCon.Execute("exec DayNot_proc '" & LastDay & "','" & (Date - 1) & "'")

'某天,除今天
Do While Not adoDay.EOF
   '某人
   TDate = adoDay!Date
   Set adoCard = adoCon.Execute("exec Card_proc")
   Do While Not adoCard.EOF
      
      TCardID = Trim(adoCard!CardID)
    Set AdoCc = New ADODB.Connection
    Set adoRR = New ADODB.Recordset
      AdoCc.ConnectionString = RtnStr
      AdoCc.Open
      
      adoRR.Open "exec KSID_proc '" & STR(TDate) & "','" & STR(TCardID) & "'", AdoCc, adOpenKeyset, adLockPessimistic
      Select Case adoRR.RecordCount
      
    Case 0
        adoCon.Execute ("exec InsertK_proc '" & TCardID & "','" & TDate & "','0','0','0','旷勤'")
 
         
    Case 1
        
        SQL = "'" & Trim(adoRR!CardID) & "',"
        SQL = SQL + "'" & Trim(adoRR!Date) & "','" & Trim(adoRR!Hour) & "',"
        SQL = SQL + "'" & Trim(adoRR!Minute) & "','" & Trim(adoRR!Second) & "',"
            Select Case Trim(adoRR!Type)
              Case "正常"
                adoCon.Execute ("exec insertK_proc" + SQL + "'旷勤半天'")
              Case "旷勤半天"
                adoCon.Execute ("exec insertK_proc" + SQL + "'旷勤'")
              Case Else
                adoCon.Execute ("exec insertK_proc" + SQL + "'" & Trim(adoRR!Type) & "'")
                adoCon.Execute ("exec insertK_proc" + SQL + "'旷勤半天'")
             End Select
   Case 2
        IIC = 0
        SQL = "insert into KaoQin values "
        SQL = SQL + "('" & Trim(adoRR!CardID) & "',"
        SQL = SQL + "'" & Trim(adoRR!Date) & "','" & Trim(adoRR!Hour) & "',"
        SQL = SQL + "'" & Trim(adoRR!Minute) & "','" & Trim(adoRR!Second) & "',"
        Select Case Trim(adoRR!Type)
        Case "正常"
        Case "旷勤半天"
                IIC = 1
                temCardID = adoRR!CardID
                temDate = adoRR!Date