modapi.bas

VB6.0编写的医院影像系统

Attribute VB_Name = "modAPI"
'本模块为包含了一些API调用的通用模块
'主要的函数有
'
' SetOnTop:         使窗体位于最上层
'
' StartSysinfo:     调用系统信息程序
'
' GetCursor:        察看当前鼠标的位置
'
' SetTextReadOnly:  使文本框为只读
'
' MMOVE:            不用点击标题栏,直接移动frm与PictureBox
'
' SetSubForm:       设置一个窗体为另一个窗体的子窗体
'
' SetDisplayMode:   设置屏幕的大小和颜色深度
'
' NumericEdit:      使某控件只接收数字的输入


' 窗体状态选项...
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40
Const SWP_HIDEWINDOW = &H80
Const SWP_NOMOVE = 2
Const SWP_NOSIZE = 1

'
' 注册键安全选项...
Const KEY_ALL_ACCESS = &H2003F
                                          

' 注册键根类型...
Public Const HKEY_LOCAL_MACHINE = &H80000002
Const ERROR_SUCCESS = 0
Const REG_SZ = 1                         ' Unicode 空结尾字符串
Const REG_DWORD = 4                      ' 32位数

' 关于sysinfo程序的一些常量...
Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"
Const gREGVALSYSINFOLOC = "MSINFO"
Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
Const gREGVALSYSINFO = "PATH"

' 关于GetCursor程序的一些常量类型
Type POINTAPI
        x As Long
        y As Long
End Type

' 关于SetTextReadOnly程序的一些常量
Const WM_USER = &H400
Const EM_SETREADONLY = &HCF


' 关于MMOVE的一些常量
Const WM_SYSCOMMAND = &H112
Const SC_MOVE = &HF012

' 关于SetDisplayMode的一些结构
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Type DEVMODE
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type


'关于CREATEPROCESS的一些变量
Public Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadID As Long
End Type

Public Type STARTUPINFO
        cb As Long
        lpReserved As String
        lpDesktop As String
        lpTitle As String
        dwX As Long
        dwY As Long
        dwXSize As Long
        dwYSize As Long
        dwXCountChars As Long
        dwYCountChars As Long
        dwFillAttribute As Long
        dwFlags As Long
        wShowWindow As Integer
        cbReserved2 As Integer
        lpReserved2 As Long
        hStdInput As Long
        hStdOutput As Long
        hStdError As Long
End Type

Public Const NORMAL_PRIORITY_CLASS = &H20
Public Const INFINITE = &HFFFF
Public Const STILL_ACTIVE = &H103



'以下为HELP用到的常数
Public Const HELP_CONTENTS = &H3&
Public Const HELP_CONTEXT = &H1
Public Const CONTENTS = 2020
Public Const EVENTS = 2022
Public Const HELP_HELPONHELP = &H4
Public Const PROPERTIES = 2002
Public Const SEARCH = 1
Public Const HELP_INDEX = &H3

'-------------------------------------------------
' 用于 GetOpenFileName API的用户定义类型
'-------------------------------------------------
Private Type OPENFILENAME
     lStructSize As Long
     hwndOwner As Long
     hInstance As Long
     lpstrFilter As String
     lpstrCustomFilter As Long
     nMaxCustFilter As Long
     nFilterIndex As Long
     lpstrFile As String
     nMaxFile As Long
     lpstrFileTitle As String
     nMaxFileTitle As Long
     lpstrInitialDir As String
     lpstrTitle As String
     Flags As Long
     nFileOffset As Integer
     nFileExtension As Integer
     lpstrDefExt As String
     lCustData As Long
     lpfnHook As Long
     lpTemplateName As Long
End Type

Public Type FileDialog
    sTitle As String
    sFilter As String
    sDefaultExt As String
    sInitDir As String
End Type


'用于 GetOpenFileName API
Const OFN_READONLY = &H1
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_SHOWHELP = &H10
Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLETEMPLATE = &H40
Const OFN_ENABLETEMPLATEHANDLE = &H80
Const OFN_NOVALIDATE = &H100
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXTENSIONDIFFERENT = &H400
Const OFN_PATHMUSTEXIST = &H800
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_CREATEPROMPT = &H2000
Const OFN_SHAREAWARE = &H4000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOTESTFILECREATE = &H10000
Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHARENOWARN = 1
Const OFN_SHAREWARN = 0


'用于改变ListView的形状
Const HDS_BUTTONS = &H2
Const LVM_FIRST = &H1000
Const LVM_GETHEADER = (LVM_FIRST + 31)
Const GWL_STYLE = (-16)



' -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' 以下为所用到的API声明
' -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Public Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As Long, lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetOpenFileName Lib "COMDLG32" Alias "GetOpenFileNameA" (OPENFILENAME As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Public Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Public 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowWord Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal wNewWord As Long) As Long
Private 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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Public Declare Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (lpString1 As Any, lpString2 As Any) As Long
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (ByVal lpDevMode As Long, ByVal dwFlags As Long) As Long
Public 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
Private 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 ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long


Public Function SetLvwPlainHead(lvw As ListView, FormHwnd As Long)
    
    '将一个ListView的HEAD设置为平板状
    Dim r As Long
    Dim style As Long
    Dim hHeader As Long
    hHeader = SendMessage(lvw.hwnd, LVM_GETHEADER, 0, ByVal 0&)
    style = GetWindowLong(hHeader, GWL_STYLE)
    style = style Xor HDS_BUTTONS     'set the new style and redraw the listview
    If style Then
        r = SetWindowLong(hHeader, GWL_STYLE, style)
        r = SetWindowPos(lvw.hwnd, FormHwnd, 0, 0, 0, 0, SWP_FLAGS)
    End If
    
End Function

Public Sub GotoURL(hwnd As Long, URL As String)
    
    '---------------------------------
    '跳转到某一URL
    '---------------------------------
    
    Dim Ret
    Ret = ShellExecute(hwnd, "Open", URL, "", App.Path, 1)
    
End Sub


Public Sub SetOnTop(ByRef frm As Form, ByVal bStatus As Boolean)
    
    
    '--------------------------------------