module1.bas

提供一个网吧管理系统的VB源代码供大家学习

Attribute VB_Name = "Module1"
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public SelectComputer As Long

Public SystemPath As String
Public UserName As String
Public UserPass As String
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Type Lwinsock
   Ip As String
   Index As Long
   JSJ As Long
End Type

Public IndexSock() As Lwinsock

Type lChatUser
   Name As String
   Sex As String
   Used As Boolean
End Type
Public IChatUser() As lChatUser

Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As Long

Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

Public Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long

Declare Function SystemParametersInfoByRef Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

Public IsupperMsg As Integer

Public Const LB_SETHORIZONTALEXTENT = &H194
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long


Public Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long


Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Boolean
    Dim s As String
    
    s = String(80, 0)
    Call GetWindowText(hWnd, s, 80)
    s = Left(s, InStr(s, Chr(0)) - 1)
    
    If Len(s) > 0 Then
      If InStr(1, s, "网吧记费器——用户：") Then
       BringWindowToTop hWnd
      End If
    
    
    End If
    
    EnumWindowsProc = True
End Function

Function GetWeek(setDate As Date) As String
ww = Weekday(setDate, vbSunday)
Select Case ww
Case 1
GetWeek = "星期日"
Case 2
GetWeek = "星期一"
Case 3
GetWeek = "星期二"
Case 4
GetWeek = "星期三"
Case 5
GetWeek = "星期四"
Case 6
GetWeek = "星期五"
Case 7
GetWeek = "星期六"
End Select
End Function

Function SupperMsgbox(ParamArray Msg()) As Integer
'
On Error Resume Next
'SupperMsgbox = vbNo
frmMsgBox.Label1 = Msg(0)
Select Case Msg(1)
Case vbYesNo
 frmMsgBox.Command1.Caption = "是(&Y)"
 frmMsgBox.Command2.Caption = "否(&N)"
Case vbOKCancel
 frmMsgBox.Command1.Caption = "确定"
 frmMsgBox.Command2.Caption = "取消"
Case Else
 frmMsgBox.Command2.Visible = False
 frmMsgBox.Command1.Caption = "确定"
End Select
 frmMsgBox.Caption = App.Title
If Msg(2) <> "" Then
 frmMsgBox.Caption = Msg(2)


End If
frmMsgBox.Lentime = 15
frmMsgBox.Lentime = Msg(3)
frmMsgBox.Label2.Caption = "窗口将在" & frmMsgBox.Lentime & "秒后关闭"
frmMsgBox.Show vbModal, frmMain
SupperMsgbox = IsupperMsg
'MsgBox SupperMsgbox
End Function

Function ISRegRight() As Boolean
'是否注册
'On Error Resume Next
ISRegRight = False
Dim sjscount As Long
sjscount = GetSetting("网吧记费器", "reg", "机器数", 10)
If sjscount < frmMain.Data1.Recordset.RecordCount Then
  ISRegRight = False
  Exit Function
End If
pass = GetSetting("网吧记费器", "reg", "Reg", "")
'MsgBox RegNumBer(10)

If RegPassEd(RegNumBer(sjscount)) = pass Then
ISRegRight = True
End If
End Function


Function RegNumBer(sjscount As Long) As String
Dim lSerialNum As Long, strLabel As String, strType As String

strLabel = String$(255, Chr(0))

strType = String$(255, Chr(0))
Dim max As Long
R = GetVolumeInformation(Left(App.Path, 3), strLabel, Len(strLabel), lSerialNum, 0, 0, strType, Len(strType))
Dim tLabel As String, tFormat As String
tLabel = Mid(strLabel, InStr(1, strLabel, Chr(0)))
'tFormat = lSerialNum)
Dim bb   As Double
bb = (lSerialNum \ (sjscount + 182)) * sjscount
tFormat = Hex$(bb)
'MsgBox tFormat, , tFormat
RegNumBer = ""
Dim regNumm(10) As String
For i = 1 To Len(tFormat)
 aa = Asc(Mid(tFormat, i, 1))
 aa = (161 - aa) * 2 \ 3 + i * 2
 regNumm(i) = Hex(aa)
Next i
RegNumBer = regNumm(7) + regNumm(1) + regNumm(8) + regNumm(5) + regNumm(3) + regNumm(2) + regNumm(4) + regNumm(6)
If Len(RegNumBer) < 16 Then
For i = 1 To 16 - Len(RegNumBer)
RegNumBer = RegNumBer + Chr(91 - i)
Next i
End If
End Function

Function RegPassEd(tFormat As String) As String
Dim ss(16) As String
For i = 1 To Len(tFormat)
 aa = Asc(Mid(tFormat, i, 1))
 aa = ((aa * 76 + 45) \ 82) * 771 * 16 \ 752
 ss(i) = Hex(aa)
Next i
RegPassEd = ss(3) + ss(1) + ss(7) + ss(5) + ss(2) + ss(8) + ss(6) + ss(4) + ss(11) + ss(9) + ss(15) + ss(13) + ss(10) + ss(16) + ss(14) + ss(12)
RegPassEd = Mid(RegPassEd, 5, 20)
End Function