module2.bas

KTV管理系统,实现了基本的日常操作.程序有不完善之处,请自修升级修改.

Attribute VB_Name = "Module2"

'===========对INI文件的读写==================
#If Win16 Then
        Declare Function WritePrivateProfileString Lib "Kernel" (ByVal AppName As String, ByVal KeyName As String, ByVal NewString As String, ByVal fileName As String) As Integer
        Declare Function GetPrivateProfileString Lib "Kernel" Alias "GetPrivateProfilestring" (ByVal AppName As String, ByVal KeyName As Any, ByVal default As String, ByVal ReturnedString As String, ByVal MAXSIZE As Integer, ByVal fileName As String) As Integer
#Else
        Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
        Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As Any, ByVal lpFileName As String) As Long
#End If
'=============注册表操作======================
Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4

Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const HKEY_CURRENT_USER = &H80000001
Global Const HKEY_LOCAL_MACHINE = &H80000002
Global Const HKEY_USERS = &H80000003

Global Const ERROR_NONE = 0
Global Const ERROR_BADDB = 1
Global Const ERROR_BADKEY = 2
Global Const ERROR_CANTOPEN = 3
Global Const ERROR_CANTREAD = 4
Global Const ERROR_CANTWRITE = 5
Global Const ERROR_OUTOFMEMORY = 6
Global Const ERROR_INVALID_PARAMETER = 7
Global Const ERROR_ACCESS_DENIED = 8
Global Const ERROR_INVALID_PARAMETERS = 87
Global Const ERROR_NO_MORE_ITEMS = 259

Global Const KEY_ALL_ACCESS = &H3F

Global Const REG_OPTION_NON_VOLATILE = 0

Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey& Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String)
Private Declare Function RegDeleteValue& Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String)
'=========读取 文件的建立时间与修改时间=============================
Public Const OFS_MAXPATHNAME = 128

Public Const OF_READ = &H0

Type OFSTRUCT

cBytes As Byte

fFixedDisk As Byte

nErrCode As Integer

Reserved1 As Integer

Reserved2 As Integer

szPathName(OFS_MAXPATHNAME) As Byte

End Type


Type SYSTEMTIME

wYear As Integer

wMonth As Integer

wDayOfWeek As Integer

wDay As Integer

wHour As Integer

wMinute As Integer

wSecond As Integer

wMilliseconds As Integer

End Type


Type FileTime

dwLowDateTime As Long

dwHighDateTime As Long

End Type



Type BY_HANDLE_FILE_INFORMATION

dwFileAttributes As Long

ftCreationTime As FileTime

ftLastAccessTime As FileTime

ftLastWriteTime As FileTime

dwVolumeSerialNumber As Long

nFileSizeHigh As Long

nFileSizeLow As Long

nNumberOfLinks As Long

nFileIndexHigh As Long

nFileIndexLow As Long

End Type


Type TIME_ZONE_INFORMATION

bias As Long

StandardName(32) As Integer

StandardDate As SYSTEMTIME

StandardBias As Long

DaylightName(32) As Integer

DaylightDate As SYSTEMTIME

DaylightBias As Long

End Type


Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long

Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long

Declare Function GetFileInformationByHandle Lib "kernel32" (ByVal hFile As Long, lpFileInformation As BY_HANDLE_FILE_INFORMATION) As Long

Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FileTime, lpSystemTime As SYSTEMTIME) As Long

Dim FileHandle As Long

Dim FileInfo As BY_HANDLE_FILE_INFORMATION

Dim lpReOpenBuff As OFSTRUCT, ft As SYSTEMTIME

Dim tZone As TIME_ZONE_INFORMATION
Dim bias As Long

'=============获得系统system32目录==================
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'===============获得硬盘序列号=====================
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long



'==========文件建立时间===============
Public Function dtCreate(fileName As String) As Date
'： 先取得 的 File Handle
FileHandle = OpenFile(fileName, lpReOpenBuff, OF_READ)

'： 利用 File Handle 读取文件资讯

Call GetFileInformationByHandle(FileHandle, FileInfo)

Call CloseHandle(FileHandle)
'： 读取 Time Zone 资讯， 因为上一步骤的文件时间是「格林威治」时间

Call GetTimeZoneInformation(tZone)

bias = tZone.bias '： 时间差， 以「分」为单位

Call FileTimeToSystemTime(FileInfo.ftCreationTime, ft) '： 转换时间资料结构

dtCreate = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + TimeSerial(ft.wHour, ft.wMinute - bias, ft.wSecond)
End Function
'===========文件修改时间=============================
Public Function dtWrite(fileName As String) As Date
'： 先取得 的 File Handle
FileHandle = OpenFile(fileName, lpReOpenBuff, OF_READ)

'： 利用 File Handle 读取文件资讯

Call GetFileInformationByHandle(FileHandle, FileInfo)

Call CloseHandle(FileHandle)
'： 读取 Time Zone 资讯， 因为上一步骤的文件时间是「格林威治」时间

Call GetTimeZoneInformation(tZone)

bias = tZone.bias '： 时间差， 以「分」为单位

Call FileTimeToSystemTime(FileInfo.ftLastWriteTime, ft)

dtWrite = DateSerial(ft.wYear, ft.wMonth, ft.wDay) + TimeSerial(ft.wHour, ft.wMinute - bias, ft.wSecond)

End Function

'==============获得系统ssytem32目录============
Public Function MyGetSystemDirectory() As String

    Dim sBuffer As String

    Dim lSize As Long

     sBuffer = String(255, 0)

     lSize = GetSystemDirectory(sBuffer, Len(sBuffer))

     sBuffer = Left(sBuffer, lSize)

     sBuffer = sBuffer + "\"

     MyGetSystemDirectory = sBuffer

End Function
'=================读写INI文件========================
Function ReadINI(Section, KeyName, fileName As String) As String
        Dim sRet As String
        sRet = String(255, Chr(0))
        ReadINI = Left(sRet, GetPrivateProfileString(Section, ByVal KeyName, "", sRet, Len(sRet), fileName))
End Function

Function writeini(sSection As String, sKeyName As String, sNewString As String, sFileName) As Integer
        Dim r
        r = WritePrivateProfileString(sSection, sKeyName, sNewString, sFileName)
End Function
'=================注册表操作==========================

'这是一个操作注册表的Bas文件,其中包含可以建立新键值,删除
'键值,查询键值的函数.
'演示-----
    
    '函数在注册表的"HKEY_CURRENT_USER\Software"中建立了
    '一个SubKey1项并在其中建立了值，并在显示后删除建立
    '的值，如果你想通过RegEdit看到结果，可以将最后两句
    '删除，不过要记得手动删除建立的键值
    'CreateNewKey HKEY_CURRENT_USER, "mosre"
    'SetKeyValue HKEY_CURRENT_USER, "mosre", "mainDate", "2006/1/8", REG_SZ
    'mainDate=QueryValue(HKEY_CURRENT_USER, "mosre", "mainDate")
    'DeleteValue HKEY_CURRENT_USER, "mosre", "mainDate"
    'DeleteKey HKEY_CURRENT_USER, "mosre"
Public Function DeleteKey(lPredefinedKey As Long, sKeyName As String)
    Dim lRetVal As Long
    Dim hKey As Long
    
    lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
    lRetVal = RegDeleteKey(lPredefinedKey, sKeyName)
    RegCloseKey (hKey)
End Function

Public Function DeleteValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
       Dim lRetVal As Long
       Dim hKey As Long

       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = RegDeleteValue(hKey, sValueName)
       RegCloseKey (hKey)
End Function

Public Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
    Dim lValue As Long
    Dim sValue As String

    Select Case lType
        Case REG_SZ
            sValue = vValue
            SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
        Case REG_DWORD
            lValue = vValue
            SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
        End Select

End Function

Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String

    On Error GoTo QueryValueExError

    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5

    Select Case lType
        Case REG_SZ:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch)
            Else
                vValue = Empty
            End If

        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
            If lrc = ERROR_NONE Then vValue = lValue
        Case Else
            lrc = -1
    End Select

QueryValueExExit:

    QueryValueEx = lrc
    Exit Function

QueryValueExError:

    Resume QueryValueExExit

End Function
Public Function CreateNewKey(lPredefinedKey As Long, sNewKeyName As String)
    Dim hNewKey As Long
    Dim lRetVal As Long
    
    lRetVal = RegCreateKeyEx(lPredefinedKey, sNewKeyName, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
    RegCloseKey (hNewKey)
End Function

    
Public Function SetKeyValue(lPredefinedKey As Long, sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)
       Dim lRetVal As Long
       Dim hKey As Long

       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
       RegCloseKey (hKey)

End Function

Public Function QueryValue(lPredefinedKey As Long, sKeyName As String, sValueName As String)
       Dim lRetVal As Long
       Dim hKey As Long
       Dim vValue As Variant


       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = QueryValueEx(hKey, sValueName, vValue)
       QueryValue = vValue
       RegCloseKey (hKey)
End Function
'=====================获得硬盘序列号=======================
'举例：sericnum=getserialNumber("c:\")
Function GetSerialNumber(strDrive As String) As Long

Dim SerialNum As Long

Dim Res As Long

Dim Temp1 As String

Dim Temp2 As String

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

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

Res = GetVolumeInformation(strDrive, Temp1, _
Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))

GetSerialNumber = SerialNum

End Function