www.pudn.com > netserver.zip > Module1.bas
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