module1.bas

利用VB编写的一个完整的酒店管理程序,支持双数据库!

Attribute VB_Name = "Module1"
  Option Explicit
  Public SqlFlag As String
  Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
  End Type
Public Const Constr = ";UID=;PWD=553533"
Public Const msgBoxtitle = "提示：Power By 华成."
Public Const Gongsiname = "热点软件"
Public Const DI_MASK& = 1
Public Const DI_IMAGE& = 2
Public Const DI_NORMAL& = 3
Public Const DI_DEFAULTSIZE& = 8
Public Const DI_COMPAT& = 4
Public Const FILE_ATTRIBUTE_ARCHIVE& = &H20
Public Const FILE_ATTRIBUTE_COMPRESSED& = &H800
Public Const FILE_ATTRIBUTE_DIRECTORY& = &H10
Public Const FILE_ATTRIBUTE_HIDDEN& = &H2
Public Const FILE_ATTRIBUTE_NORMAL& = &H80
Public Const FILE_ATTRIBUTE_READONLY& = &H1
Public Const FILE_ATTRIBUTE_SYSTEM& = &H4
Public Const FILE_ATTRIBUTE_TEMPORARY& = &H100
Public Const MAX_PATH& = 260
Public Const SHGFI_LARGEICON& = &H0
Public Const SHGFI_SMALLICON& = &H1
Public Const SHGFI_OPENICON& = &H2
Public Const SHGFI_SHELLICONSIZE& = &H4
Public Const SHGFI_PIDL& = &H8
Public Const SHGFI_USEFILEATTRIBUTES& = &H10
Public Const SHGFI_DISPLAYNAME& = &H200
Public Const SHGFI_ICON& = &H100
Public Const SHGFI_TYPENAME& = &H400
Public Const SHGFI_ATTRIBUTES& = &H800
Public Const SHGFI_ICONLOCATION& = &H1000
Public Const SHGFI_EXETYPE& = &H2000
Public Const SHGFI_SYSICONINDEX& = &H4000
Public Const SHGFI_LINKOVERLAY& = &H8000&
Public Const SHGFI_SELECTED& = &H10000
Public Const NOERROR& = 0
Public Const CSIDL_DESKTOP = &H0
Public Const CSIDL_PROGRAMS = &H2
Public Const CSIDL_CONTROLS = &H3
Public Const CSIDL_PRINTERS = &H4
Public Const CSIDL_PERSONAL = &H5
Public Const CSIDL_FAVORITES = &H6
Public Const CSIDL_STARTUP = &H7
Public Const CSIDL_RECENT = &H8
Public Const CSIDL_SENDTO = &H9
Public Const CSIDL_BITBUCKET = &HA
Public Const CSIDL_STARTMENU = &HB
Public Const CSIDL_DESKTOPDIRECTORY = &H10
Public Const CSIDL_DRIVES = &H11
Public Const CSIDL_NETWORK = &H12
Public Const CSIDL_NETHOOD = &H13
Public Const CSIDL_FONTS = &H14
Public Const CSIDL_TEMPLATES = &H15
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const SW_SHOWNORMAL = 1
Public Type SHFILEINFO
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End Type

Type SHITEMID
    cb As Long
    abID() As Byte
End Type

Type ITEMIDLIST
    mkid As SHITEMID
End Type

Public Type BROWSEINFO
    
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long

End Type
 Public Bac As String
 Public SystemConfigFile As String
Public Const SW_RESTORE As Long = 9&
Public Const GW_CHILD As Long = 5&
Public Const GW_HWNDNEXT As Long = 2&
Public Declare Function GetDesktopWindow& Lib "user32" ()
Public Declare Function GetWindow& Lib "user32" (ByVal hwnd&, ByVal wCmd&)
Public Declare Function GetWindowText& Lib "user32" Alias "GetWindowTextA" _
                                    (ByVal hwnd&, ByVal lpString$, ByVal cch&)
Public Declare Function ShowWindow& Lib "user32" (ByVal hwnd&, ByVal nCmdShow&)
Public Declare Function GetWindowRect& Lib "user32" (ByVal hwnd&, lpRect As RECT)
Public Declare Function MoveWindow& Lib "user32" (ByVal hwnd&, ByVal X&, _
                          ByVal y&, ByVal nWidth&, ByVal nHeight&, ByVal bRepaint&)
Public Declare Function SetForegroundWindow& Lib "user32" (ByVal hwnd&)
Public Declare Function FindWindow& Lib "user32" Alias "FindWindowA" _
                                         (ByVal lpClassName$, ByVal lpWindowName$)
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 Declare Function DrawIcon& Lib "user32" (ByVal hdc As Long, ByVal X As Long, ByVal y As Long, ByVal hIcon As Long)
Public Declare Function DrawIconEx& Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long)
Public Declare Function SHGetFileInfo& Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long)
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pIdl As Long, ByVal pszPath As String) As Long
Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pIdl As ITEMIDLIST) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) 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
Global ConData As String
Global Browser As String
Global UserText As String, PurView As String
Global strSearchString As String
Global strFileType As String, strFileID As String
Global CompanyName As String
Global IT As Boolean
Global TempArray(5) As String
Global ScanFileName As String
Public Denglu_name As String
'登陆用户名
Public Caozuo As String
Public Denglu_time As Date      '登陆时间
Public Denglu_exit As Date
'退出时间
Public lu_time As Date
Type User
    user_name As String
    user_pwd As String
End Type
'在日志文件中记录登陆时间和用户名
Public Sub RiZhi()
    Dim fos As New FileSystemObject
    Dim ts As TextStream
    Set ts = fos.OpenTextFile(App.Path + "\back\rizhi.txt", ForAppending, True)
     ts.WriteLine ("-------------------------------------" & Denglu_time)
    ts.WriteLine ("用户:" & Denglu_name & "   登陆时间:" & Denglu_time)
End Sub

'在日志文件中记录退出时间和用户名
Public Sub RiZhi1()
    Dim fos As New FileSystemObject
    Dim ts As TextStream
    Set ts = fos.OpenTextFile(App.Path + "\back\rizhi.txt", ForAppending, True)
   
     ts.WriteLine ("用户:" & Denglu_name & "   退出时间:" & Denglu_exit)
     ts.WriteLine ("-------------------------------------")
End Sub

Public Sub RiZhil()
    Dim fos As New FileSystemObject
    Dim ts As TextStream
    Set ts = fos.OpenTextFile(App.Path + "\back\rizhi.txt", ForAppending, True)
    ts.WriteLine ("用户:" & Denglu_name & "   操作内容:" & Caozuo & "  时间:" & lu_time)
End Sub


Public Sub checkPath(strCorrect As String)
'Dim FS As String, Fn As Long
 'If strCorrect = "" Then
   ' FS = GetSetting(App.EXEName, "Data", "Path")
  ' Else
  '  FS = strCorrect
 'End If
  '  Fn = FreeFile
'On Error GoTo Exist_Err
'Open FS For Input As #Fn
'Close #Fn
'  ConData = FS
 ' SaveSetting App.EXEName, "Data", "Path", ConData
'Exit Sub

'Exist_Err:

 ' MsgBox vbCrLf & "网 络 连 接 中 断 ！网 络 路 径 错 误 , 现 在 启 用 本 地 数 据 库 。        " + vbCrLf + vbCrLf + "如 果 需 要 , 请 重 新 定 义 网 络 数 据 库 的 路 径  ！    ", vbOKOnly + vbExclamation, "网络路径错误"
    
 ' ConData = App.Path + "\room.Mdb"
 ' SaveSetting App.EXEName, "Data", "Path", ConData
 Dim Fini As RegClass
'FIXIT: 用 "Right$" 函数替换 "Right" 函数                                                         FixIT90210ae-R9757-R1B8ZE
 If Right(App.Path, 1) = "\" Then
    SystemConfigFile = App.Path & "System.ini"
   Else
    SystemConfigFile = App.Path & "\System.ini"
 End If

 If Dir(SystemConfigFile, vbArchive) = "" Then
   '文件不存在时
    MsgBox "系统配置文件不存在，请重新安装系统？  ", vbCritical, "Power by 华成."
    GoTo FileOK
 End If
 
 Set Fini = New RegClass
     
     Dim sTmp As String
    
         sTmp = Fini.ReadINIString("System", "Database", "", SystemConfigFile)
         Bac = Fini.ReadINIString("System", "sysdata", "", SystemConfigFile)
     '-------------------------------------------------
     
     If sTmp = "" Then
'FIXIT: 用 "Right$" 函数替换 "Right" 函数                                                         FixIT90210ae-R9757-R1B8ZE
        If Right(App.Path, 1) = "\" Then
           ConData = App.Path & "room.mdb"
         Else
           ConData = App.Path & "\room.mdb"
        End If
       Else
        ConData = sTmp
     End If
    '--------------------------------------------------2007年1月1日开始弹出升级警告信息
   
   
   '-----------------------------------------------------
 If Dir(ConData, vbArchive) = "" Then
    MsgBox "对不起,系统与主机联系中断！" & vbCrLf & vbCrLf & "请马上查看主机情况！请关闭本软件，等主机恢复后再进入！   ", vbExclamation, msgBoxtitle
    End
 End If
 
 

FileOK:
 
 Exit Sub
  
 

End Sub


Private Sub Main()


End Sub

Private Sub ActivatePrevInstance(ByVal hAppWindow&)

  Call ShowWindow(hAppWindow, SW_RESTORE)

  '使窗口活动
  Call SetForegroundWindow(hAppWindow)
  
  
End Sub
'FIXIT: 用早期绑定的数据类型声明 "sAppPath"                                                            FixIT90210ae-R1672-R1B8ZE
Public Sub ShellGoto(sFileName As String, hwnd As Long, sAppPath)
    
  On Error Resume Next
  ShellExecute hwnd, vbNullString, sFileName, vbNullString, sAppPath, SW_SHOWNORMAL
    
End Sub
Public Function IsShare() As Boolean
 
 On Error Resume Next
 
 Dim RetVal As Boolean
 Dim WriteToReg As RegClass
 Set WriteToReg = New RegClass
    
 If Date > "2007-02-01" Then
   MsgBox "对不起,软件应该进行升级！请马上进行升级？  " & vbCrLf & vbCrLf & "如果不能升级产品请访问：http://www.lnpop.com " & vbCrLf & vbCrLf & "更多信息,拨打 13840750674 咨询？ ", vbInformation, msgBoxtitle
   IsShare = False
   '
   '已经过期,但是改了时间
   'If Val(WriteToReg.GetRegStringValue("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion", "IsShare")) <> 0 Then
   ' MsgBox "对不起,试用版已经过期,请购买完全版,统一售价【28】元 ？  " & vbCrLf & vbCrLf & "本系统已经通过软件商发行,当地软件供应商有售。  " & vbCrLf & vbCrLf & "如果不能购到该产品请访问★VB中国网：http://www.vb-code.net " & vbCrLf & vbCrLf & "更多信息,拨打 13806540284 咨询？ ", vbInformation, msgBoxtitle
                                               
   '  MsgBox "对不起,软件应该进行注册！请马上进行注册？  " & vbCrLf & vbCrLf & "在注册时候请注意注册码的大小写。  " & vbCrLf & vbCrLf & "本软件注册费用：每节点500元人民币 " & vbCrLf & vbCrLf & "更多信息,拨打 13840750674 咨询？ ", vbInformation, msgBoxtitle
      
      
    Else
       IsShare = True
    End If

 
End Function