win32bas.bas

报警信息查询系统VB+ACESS 根据某啤酒厂出现故障不同（如系统错误、负亟接地、操作错误等）计算机系统进行报警

Attribute VB_Name = "Win32Bas"

Option Explicit


'函数
Declare Function OSWinHelp% Lib "User32" Alias "WinHelpA" (ByVal hWnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Declare Function WinHelp Lib "User32" Alias "WinHelpA" (ByVal hWnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize 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 WNetCancelConnection Lib "mpr.dll" Alias "WNetCancelConnectionA" (ByVal lpszName As String, ByVal bForce As Long) As Long
Declare Function WNetAddConnection Lib "mpr.dll" Alias "WNetAddConnectionA" (ByVal lpszNetPath As String, ByVal lpszPassword As String, ByVal lpszLocalName As String) As Long

Global Const HELP_QUIT = 2
Global Const HELP_INDEX = 3
Global Const HELP_HELPONHELP = 4
Global Const HELP_PARTIALKEY = &H105
Public Const HELP_CONTENTS = &H3&
Public Const HELP_CONTEXT = &H1          '  Display topic in ulTopic
Public Const HELP_COMMAND = &H102&
Public Const HELP_KEY = &H101            '  Display topic for keyword in offabData


Global Const CB_ERR = -1
Global Const CB_FINDSTRING = &H14C
Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpbuffer As String, nSize As Long) As Long
'文件关联


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 HKEY_PERFORMANCE_DATA = &H80000004
Global Const HKEY_CURRENT_CONFIG = &H80000005
Global Const HKEY_DYN_DATA = &H80000006

Public Const REG_NONE = 0
Public Const REG_SZ = 1
Public Const REG_EXPAND_SZ = 2
Public Const REG_BINARY = 3
Public Const REG_DWORD = 4
Public Const REG_DWORD_BIG_ENDIAN = 5
Public Const REG_MULTI_SZ = 7

Public Const MAX_PATH = 260

Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
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
Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal hKey As Long, ByVal lpClass As String, lpcbClass As Long, lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, lpcbMaxValueLen As Long, lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) As Long
Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long

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 Const WN_Success = &H0
Public Const WN_Not_Supported = &H1
Public Const WN_Net_Error = &H2
Public Const WN_Bad_Pointer = &H4
Public Const WN_Bad_NetName = &H32
Public Const WN_Bad_Password = &H6
Public Const WN_Bad_Localname = &H33
Public Const WN_Access_Denied = &H7
Public Const WN_Out_Of_Memory = &HB
Public Const WN_Already_Connected = &H34


Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOZORDER = &H4
Public Const SWP_NOREDRAW = &H8
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_FRAMECHANGED = &H20        '  The frame changed: send WM_NCCALCSIZE
Public Const SWP_SHOWWINDOW = &H40
Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_NOCOPYBITS = &H100
Public Const SWP_NOOWNERZORDER = &H200      '  Don't do owner Z ordering

Public Const HWND_TOP = 0
Public Const HWND_BOTTOM = 1
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2



Function sGetComputerName() As String
  Dim sBuffer As String
  Dim lBufSize As Long
  Dim lStatus As Long
  
  lBufSize = 255
  sBuffer = String$(lBufSize, " ")
  lStatus = GetComputerName(sBuffer, lBufSize)
  sGetComputerName = ""
  If lStatus <> 0 Then
     sGetComputerName = Left(sBuffer, lBufSize)
  End If
  
End Function



Function ReplaceString(OldStr As String, NewStr As String, ByVal AllStr As String) As String
Dim i As Integer, TempFStr As String

i = InStr(1, UCase(AllStr), UCase(OldStr))
If i = 0 Then
   ReplaceString = AllStr
   Exit Function
End If
TempFStr = Mid(AllStr, 1, i - 1)
AllStr = Mid(AllStr, i + Len(OldStr), Len(AllStr) - (i + Len(OldStr)) + 1)
ReplaceString = TempFStr & NewStr & AllStr


End Function






Function SetExtOperation(ByVal ext As String) As String
    Dim hKey As Long, typeData As Long, lenData As Long
    Dim S As String, ret As Long, Name As String, Idx As Long
    Dim nSubKey As Long, maxSubKeyLen As Long, maxClassLen As Long
    Dim nValue As Long, maxValueNameLen As Long, maxValueLen As Long
    Dim sd As Long, WriteTime As FILETIME
    
    ret = RegOpenKey(HKEY_CLASSES_ROOT, ext, hKey)
    If ret <> 0 Then
        MsgBox "此一扩展名没有关联程序,或未选择操作文件的方式！", vbExclamation
        Exit Function
    End If
    ret = RegQueryValueEx(hKey, "", 0, typeData, ByVal vbNullString, lenData)
    If ret = 0 Then
        S = String(lenData, Chr(0))
        RegQueryValueEx hKey, "", 0, typeData, ByVal S, lenData
        S = Left(S, InStr(S, Chr(0)) - 1)
        
        ret = RegOpenKey(HKEY_CLASSES_ROOT, S & "\shell", hKey)
        If ret <> 0 Then
            MsgBox "此一扩展名没有关联程序,或未选择操作文件的方式！", vbExclamation
            Exit Function
        End If
        ret = RegQueryInfoKey(hKey, vbNullString, 0, ByVal 0, _
                    nSubKey, maxSubKeyLen, maxClassLen, nValue, _
                    maxValueNameLen, maxValueLen, sd, WriteTime)
        Name = String(maxSubKeyLen + 1, Chr(0))
    
        For Idx = 0 To nSubKey - 1
            ret = RegEnumKey(hKey, Idx, Name, Len(Name))
            If ret = 0 Then
                SetExtOperation = Left(Name, InStr(Name, Chr(0)) - 1)
                RegCloseKey hKey
                Exit Function
            End If
        Next
    End If
    MsgBox "此一扩展名没有关联程序,或未选择操作文件的方式！", vbExclamation
    RegCloseKey hKey
End Function