module1.bas

星级酒店管理系统VB源代码

Attribute VB_Name = "Module1"
'************************************************
' This Program is Designed To Create a System DSN
' Using Access Database (Microsoft Jet Engine)
' To Run this Program effectively You should have
' Microsoft Access Driver (*.mdb) installed on your
' Machine
' ***********************************************

Option Explicit
Private Const REG_SZ = 1         'Constant for a string variable type.
Private Const REG_BINARY = 3     'Constant for Binary
Private Const REG_DWORD = 4      '32-bit number

Private Const HKEY_LOCAL_MACHINE = &H80000002

'Creates a Key In Registry
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
'API FOR STRING
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
'API FOR DWORD
Private Declare Function RegSetValueExA Lib "advapi32.dll" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Long, ByVal cbData As Long) As Long
'API FOR BINARY
Private Declare Function RegSetValueExB Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Byte, ByVal cbData As Long) As Long
'API for closing the Registry Key
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

'******************************

Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Public Const DRIVE_CDROM = 5
Public Const DRIVE_FIXED = 3
Public Const DRIVE_RAMDISK = 6
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_REMOVABLE = 2

Private 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

Private Const FS_CASE_IS_PRESERVED = 2
Private Const FS_CASE_SENSITIVE = 1
Private Const FS_UNICODE_STORED_ON_DISK = 4
Private Const FS_PERSISTENT_ACLS = 8
Private Const FS_FILE_COMPRESSION = 16
Private Const FS_VOL_IS_COMPRESSED = 32768

Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long

Public Type DiskInformation
    lpSectorsPerCluster As Long
    lpBytesPerSector As Long
    lpNumberOfFreeClusters As Long
    lpTotalNumberOfClusters As Long
End Type

Public fMainForm As New frmMain
Public myIndex As Variant

Sub Main()
    Dim s1, s2, s3 As String
    s1 = GetSetting("wlf", "DM", "path", Default:="")
    s2 = GetSetting("wlf", "DM", "date", Default:="")
    s3 = GetSetting("wlf", "DM", "UserName", Default:="")
    
    If s1 = "" Then
        SaveSetting "wlf", "DM", "path", "D:\"
    End If
    If s2 = "" Then
        SaveSetting "wlf", "DM", "date", Date
    End If
    
    frmSplash.Show
    frmSplash.Refresh
    
    If s3 = "" Then
        frmLogin.Show (1)
    End If
    
    Load fMainForm
    Unload frmSplash
    
    fMainForm.Show
End Sub

Public Function FreeSpace() As String
    Dim Info As DiskInformation
    Dim lAnswer As Long
    Dim lpRootPathName As String
    Dim lpSectorsPerCluster As Long
    Dim lpBytesPerSector As Long
    Dim lpNumberOfFreeClusters As Long
    Dim lpTotalNumberOfClusters As Long
    Dim lBytesPerCluster As Long
    Dim lNumFreeBytes As Double
    Dim sString As String
    
    sString = ""
    lpRootPathName = "c:\"
    lAnswer = GetDiskFreeSpace(lpRootPathName, lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters)
    lBytesPerCluster = lpSectorsPerCluster * lpBytesPerSector
    lNumFreeBytes = lBytesPerCluster * lpNumberOfFreeClusters
    'sString = "Number of Free Bytes : " & lNumFreeBytes & vbCr & vbLf
    'sString = sString & "Number of Free Kilobytes: " & (lNumFreeBytes / 1024) & "K" & vbCr & vbLf
    sString = sString & "C:剩余空间 " & Format(((lNumFreeBytes / 1024) / 1024), "0.00") & "MB"
    
    FreeSpace = sString

End Function

Public Function GetDriveInfo() As String
Dim strRootPathName As String
Dim strVolumeNameBuffer As String * 256
Dim lngVolumeNameSize As Long
Dim lngVolumeSerialNumber As Long
Dim lngMaximumComponentLength As Long
Dim lngFileSystemFlags As Long
Dim strFileSystemNameBuffer As String * 256
Dim lngFileSystemNameSize As Long
Dim strMessage As String

    strRootPathName = "C:\" 'drive letter
    
    If GetVolumeInformation(strRootPathName, strVolumeNameBuffer, Len(strVolumeNameBuffer), lngVolumeSerialNumber, lngMaximumComponentLength, lngFileSystemFlags, strFileSystemNameBuffer, Len(strFileSystemNameBuffer)) = 0 Then
        strMessage = "An error occurred!"
    Else
        strMessage = strRootPathName
        strVolumeNameBuffer = Left$(strVolumeNameBuffer, InStr(strVolumeNameBuffer, Chr$(0)) - 1)
        strMessage = strMessage & vbCrLf & "Volume Name: " & strVolumeNameBuffer
        strMessage = strMessage & vbCrLf & "Serial number: " & Format$(lngVolumeSerialNumber)
        strMessage = strMessage & vbCrLf & "Max component length: " & Format$(lngMaximumComponentLength)
        strMessage = strMessage & vbCrLf & "System Flags: "
        If lngFileSystemFlags And FS_CASE_IS_PRESERVED Then strMessage = strMessage & vbCrLf & "    FS_CASE_IS_PRESERVED"
        If lngFileSystemFlags And FS_CASE_SENSITIVE Then strMessage = strMessage & vbCrLf & "    FS_CASE_SENSITIVE"
        If lngFileSystemFlags And FS_UNICODE_STORED_ON_DISK Then strMessage = strMessage & vbCrLf & "    FS_UNICODE_STORED_ON_DISK"
        If lngFileSystemFlags And FS_PERSISTENT_ACLS Then strMessage = strMessage & vbCrLf & "    FS_PERSISTENT_ACLS"
        If lngFileSystemFlags And FS_FILE_COMPRESSION Then strMessage = strMessage & vbCrLf & "    FS_FILE_COMPRESSION"
        If lngFileSystemFlags And FS_VOL_IS_COMPRESSED Then strMessage = strMessage & vbCrLf & "    FS_VOL_IS_COMPRESSED"
        strFileSystemNameBuffer = Left$(strFileSystemNameBuffer, InStr(strFileSystemNameBuffer, Chr$(0)) - 1)
        strMessage = strMessage & vbCrLf & "File System: " & strFileSystemNameBuffer
    End If

    GetDriveInfo = strMessage

End Function

Public Function GetDrives() As String
Dim strDrive As String
Dim strMessage As String
Dim intCnt As Integer
Dim rtn As String

For intCnt = 65 To 86
    strDrive = Chr(intCnt)
    Select Case GetDriveType(strDrive + ":\")
           Case DRIVE_REMOVABLE
                rtn = "Floppy Drive"
           Case DRIVE_FIXED
                rtn = "Hard Drive"
           Case DRIVE_REMOTE
                rtn = "Network Drive"
           Case DRIVE_CDROM
                rtn = "CD-ROM Drive"
           Case DRIVE_RAMDISK
                rtn = "RAM Disk"
           Case Else
                rtn = ""
    End Select
    If rtn <> "" Then
        strMessage = strMessage & vbCrLf & "Drive " & strDrive & " is type: " & rtn
    End If
Next intCnt
GetDrives = strMessage
End Function

Public Function RegisterDSN()
    Dim en As rdoEnvironment
    Dim cnTest As rdoConnection
    Dim strAttribs As String
    ' Build keywords string.
    strAttribs = "Description=" _
            & "Access on server " _
      & Chr$(13) & "OemToAnsi=No" _
      & Chr$(13) & "Database=d:\myproducts\database\dm.mde"
      
    ' Create new registered DSN.
    
    rdoEngine.rdoRegisterDataSource "DMA", _
             "Microsoft Access Driver", True, strAttribs
    ' Open the database.
    Set en = rdoEngine.rdoEnvironments(0)
    Set cnTest = en.OpenConnection( _
      dsname:="DMA", _
      prompt:=rdDriverNoPrompt, _
      Connect:="UID=;PWD=;")
  
End Function


Private Sub cmdDSN_Click()

   Dim DataSourceName               As String
   Dim DatabaseName                 As String
   Dim Description                  As String
   Dim DriverPath                   As String
   Dim DriverName                   As String
   Dim LastUser                     As String
   Dim Regional                     As String
   Dim Server                       As String

   Dim lResult                      As Long
   Dim hKeyHandle                   As Long
  
   Dim Engines                      As String
   Dim Jet                          As String
   
   Dim DBQPath                      As String
   Dim Driver                       As String
   Dim DriverId                     As Long
   Dim FIL                          As String
   Dim SafeTransaction              As Long
   Dim UID                          As String
   
   Dim ImplicitCommitSync           As String
   Dim MaxBufferSize                As Long
   Dim PageTimeOut                  As Long
   Dim Threads                      As Long
   Dim UserCommitSync               As String
   Dim Password                     As String
   
   
   DataSourceName = "DM"
   Engines = "Engines"
   Jet = "Jet"
   DBQPath = App.Path
   Driver = "C:\WinNT\system32\odbcjt32.dll"
   UID = ""
   FIL = "MS Access;"
   DriverId = &H19
   SafeTransaction = &H0
   ImplicitCommitSync = ""
   MaxBufferSize = &H800
   PageTimeOut = &H5
   Threads = &H3
   UserCommitSync = ""
   Password = ""

   'Specify the DSN parameters.
   
   On Error GoTo ErrorHandler
   
   'If You are using Windows NT use the folllowing Drivers
   Driver = "C:\WinNT\system32\odbcjt32.dll"
      
   'If You are using Windows 95,98 uncomment the following line and comment the above line
   'Driver = "C:\Windows\system\odbcjt32.dll"
   
   
  
   'Create the new DSN key.
   lResult = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" & _
        DataSourceName, hKeyHandle)

                'DBQ
            lResult = RegSetValueEx(hKeyHandle, "DBQ", 0&, REG_SZ, _
                ByVal DBQPath, Len(DBQPath))
                
                'Driver
            lResult = RegSetValueEx(hKeyHandle, "Driver", 0&, REG_SZ, _
                ByVal Driver, Len(Driver))
                
            lResult = RegSetValueExA(hKeyHandle, "DriverId", 0, REG_DWORD, DriverId, 4)  'write the value
                
                'FIL
            lResult = RegSetValueEx(hKeyHandle, "FIL", 0&, REG_SZ, _
                ByVal FIL, Len(FIL))
                
            lResult = RegSetValueExA(hKeyHandle, "SafeTransaction", 0, REG_DWORD, SafeTransaction, 4)  'write the value
                
            'Password
            lResult = RegSetValueEx(hKeyHandle, "PWD", 0&, REG_SZ, _
                ByVal Password, Len(Password))
                
            'UID
            lResult = RegSetValueEx(hKeyHandle, "UID", 0&, REG_SZ, _
                ByVal UID, Len(UID))


   lResult = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" & DataSourceName & "\" & _
        Engines, hKeyHandle)

   lResult = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" & DataSourceName & "\" & Engines & "\" & _
        Jet, hKeyHandle)
        
            'ImplicitCommitsync
            lResult = RegSetValueEx(hKeyHandle, "ImplicitCommitSync", 0&, REG_SZ, _
                ByVal ImplicitCommitSync, Len(ImplicitCommitSync))
            'MaxBufferSize
            lResult = RegSetValueExA(hKeyHandle, "MaxBufferSize", 0, REG_DWORD, MaxBufferSize, 4)  'write the value
            'PageTimeOut
            lResult = RegSetValueExA(hKeyHandle, "PageTimeOut", 0, REG_DWORD, PageTimeOut, 4)  'write the value
            'Threads
            lResult = RegSetValueExA(hKeyHandle, "Threads", 0, REG_DWORD, Threads, 4)  'write the value
            'UserCommitSync
            lResult = RegSetValueEx(hKeyHandle, "UserCommitSync", 0&, REG_SZ, _
                ByVal UserCommitSync, Len(UserCommitSync))

   'Close the new DSN key.
   lResult = RegCloseKey(hKeyHandle)

   'Open ODBC Data Sources key to list the new DSN in the ODBC Manager.
   'Specify the new value.
   'Close the key.

   lResult = RegCreateKey(HKEY_LOCAL_MACHINE, _
      "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", hKeyHandle)
   lResult = RegSetValueEx(hKeyHandle, DataSourceName, 0&, REG_SZ, _
      ByVal DriverName, Len(DriverName))
   lResult = RegCloseKey(hKeyHandle)
   MsgBox "DSN Creation Successfull !", vbExclamation
   Exit Sub
   
ErrorHandler:
   MsgBox "Error In Creating DSN"
   Exit Sub
End Sub