modapi.bas

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

    '切换窗口是否在最前面
    '--------------------------------------
    
    
    On Error GoTo SetOnTopErr
        
    With frm
        '----------------------------------------------------
        ' 如果bStatus为真,则将该frm设置为总在最前面
        '----------------------------------------------------
        If bStatus Then
            SetWindowPos .hwnd, HWND_TOPMOST, .Left / 15, .Top / 15, .width / 15, .height / 15, SWP_NOACTIVATE Or SWP_SHOWWINDOW
        Else
            SetWindowPos .hwnd, HWND_NOTOPMOST, .Left / 15, .Top / 15, .width / 15, .height / 15, SWP_NOACTIVATE Or SWP_SHOWWINDOW
        End If
    End With
        
    Exit Sub

SetOnTopErr:
    MsgBox "对此窗体不能进行设置为最前面的操作。", vbOKOnly, "操作失败"
    
End Sub

Public Sub SetWindowOnTop(frmIn As Form)
    
    '---------------------------------
    '将窗口放在最前面
    '---------------------------------
    
    SetWindowPos frmIn.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE

End Sub


Public Sub StartSysInfo()

    '----------------------------
    '启动系统信息
    '----------------------------
    
    On Error GoTo SysInfoErr

    Dim rc As Long
    Dim SysInfoPath As String

    ' 从注册表获得系统信息程序路径\名称...
    If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
        ' 仅从注册表获得系统信息程序路径...
    ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
        ' 验证已知的 32 位文件版本的存在
        If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
            SysInfoPath = SysInfoPath & "\MSINFO32.EXE"

            ' 错误 - 文件找不到...
        Else
            GoTo SysInfoErr
        End If
        ' 错误 - 注册表项找不到...
    Else
        GoTo SysInfoErr
    End If
        
    Call Shell(SysInfoPath, vbNormalFocus)

    Exit Sub
SysInfoErr:
    MsgBox "此时系统信息不可用", vbOKOnly
End Sub


Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
    Dim i As Long                                           ' 循环记数器
    Dim rc As Long                                          ' 返回代码
    Dim hKey As Long                                        ' 打开的注册表键句柄
    Dim hDepth As Long                                      '
    Dim KeyValType As Long                                  ' 注册表键数据类型
    Dim tmpVal As String                                    ' 临时存储一个注册表键值
    Dim KeyValSize As Long                                  ' 注册表键变量大小
    '------------------------------------------------------------
    ' 在键根{HKEY_LOCAL_MACHINE...}之下打开注册键
    '------------------------------------------------------------
    rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' 打开注册表键
        

    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' 错误处理...
        

    tmpVal = String$(1024, 0)                             ' 分配变量空间
    KeyValSize = 1024                                       ' 标记变量大小
        

    '------------------------------------------------------------
    ' 检索注册表键值...
    '------------------------------------------------------------
    rc = RegQueryValueEx(hKey, SubKeyRef, 0, KeyValType, tmpVal, KeyValSize)    ' 获得/创建键值
                                                

    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' 错误处理
      

    'vbe:34126
    tmpVal = Left(tmpVal, InStr(tmpVal, Chr(0)) - 1)


    '------------------------------------------------------------
    ' 决定转换的键值类型...
    '------------------------------------------------------------
    Select Case KeyValType                                  ' 搜索数据类型...
        Case REG_SZ                                             ' 字符串注册表键数据类型
            KeyVal = tmpVal                                     ' 复制字符串值
        Case REG_DWORD                                          ' 双精度注册表键数据类型
            For i = Len(tmpVal) To 1 Step -1                    ' 转换每一页
                KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   ' 一个字符一个字符地生成值
            Next
            KeyVal = Format$("&h" + KeyVal)                     ' 转换双精度为字符串
    End Select
        
    GetKeyValue = True                                      ' 返回成功
    rc = RegCloseKey(hKey)                                  ' 关闭注册表键
    Exit Function                                           ' 退出
        
GetKeyError:        ' 当发生错误时清除纪录...
    KeyVal = ""                                             ' 设返回值为空字符串
    GetKeyValue = False                                     ' 返回失败
    rc = RegCloseKey(hKey)                                  ' 关闭注册表键
End Function




Public Sub GetCursor(x As Integer, y As Integer)

    Dim PT As POINTAPI
    Call GetCursorPos(PT)
    x = PT.x * 15
    y = PT.y * 15
    
End Sub

Public Sub SetTextReadOnly(txt As Object, Status As Boolean)
    On Error Resume Next
    Dim r As Integer
    r = SendMessage(txt.hwnd, EM_SETREADONLY, Status, 0&)
End Sub

Public Sub MMOVE(obj As Object)
    
    On Error Resume Next
    ReleaseCapture
    SendMessage obj.hwnd, WM_SYSCOMMAND, SC_MOVE, 0
    
End Sub

Public Sub SetSubForm(frmSub As Form, frmMother As Form)
    SetWindowWord frmSub.hwnd, -8, frmMother.hwnd
End Sub


Public Function SetDisplayMode(width As Integer, height As Integer, Color As Integer) As Long

    '---------------------------------
    '动态切换屏幕分辨率函数
    '---------------------------------
    
    Const DM_PELSWIDTH = &H80000
    Const DM_PELSHEIGHT = &H100000
    Const DM_BITSPERPEL = &H40000
    Dim NewDevMode As DEVMODE
    Dim pDevmode As Long
    With NewDevMode
        .dmSize = 122
        If Color = -1 Then
            .dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
        Else
            .dmFields = DM_PELSWIDTH Or _
                    DM_PELSHEIGHT Or DM_BITSPERPEL
        End If
        .dmPelsWidth = width
        .dmPelsHeight = height
        If Color <> -1 Then
            .dmBitsPerPel = Color
        End If
    End With
    pDevmode = lstrcpy(NewDevMode, NewDevMode)
    SetDisplayMode = ChangeDisplaySettings(pDevmode, 0)
    
End Function

Sub NumericEdit(TheControl As Control)
    
    '---------------------------------
    '将某空间设置为只能编辑数字
    '---------------------------------
    
    Const ES_NUMBER = &H2000&
    Const GWL_STYLE = (-16)
    Dim x As Long
    Dim Estyle As Long
    Estyle = GetWindowLong(TheControl.hwnd, GWL_STYLE)
    Estyle = Estyle Or ES_NUMBER
    x = SetWindowLong(TheControl.hwnd, GWL_STYLE, Estyle)
    
End Sub


'Public Function ShowTaskBar(Optional bShow As Boolean = True) As Boolean
'
'    '-------------------------------
'    '显示/隐藏工具栏
'    '-------------------------------
'    Dim hWnd1 As Long
'
'    hWnd1 = FindWindow("Shell_traywnd", "")
'
'    If bShow Then
'        Call SetWindowPos(hWnd1, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
'    Else
'        Call SetWindowPos(hWnd1, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
'    End If
'
'End Function

'
'以下的部分是用于执行打开/关闭对话框的
'

'-------------------------------------------------
' WinAPI 声明
'-------------------------------------------------

'-------------------------------------------------
' 用户定义类型
'-------------------------------------------------

Function WinFileDialog(typOpenDialog As FileDialog, iIndex As Integer) As String
    
    Dim OPENFILENAME As OPENFILENAME
    Dim message$, FileName$, FilesDlgTitle
    Dim szCurDir$, iReturn As Integer
    Dim pathname As String, sAppName As String
        
    'Allocate string space for the returned strings.
    FileName$ = Chr$(0) & Space$(255) & Chr$(0)
    FilesDlgTitle = Chr$(0) & Space$(255) & Chr$(0)
    
    '在调用 GetOpenFileName 之前，设置数据结构
    With OPENFILENAME
        .lStructSize = Len(OPENFILENAME)
        .hwndOwner = GetActiveWindow&
        .lpstrFilter = typOpenDialog.sFilter
        .nFilterIndex = 1
        .lpstrFile = FileName$
        .nMaxFile = Len(FileName$)
        .nMaxFileTitle = Len(typOpenDialog.sTitle)
        .lpstrTitle = typOpenDialog.sTitle
        .Flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY
        .lpstrDefExt = typOpenDialog.sDefaultExt
        .lpstrInitialDir = typOpenDialog.sInitDir
    End With
        
    If iIndex = 1 Then
        iReturn = GetOpenFileName(OPENFILENAME)
    Else
        iReturn = GetSaveFileName(OPENFILENAME)
    End If
    If iReturn Then
        WinFileDialog = Left(OPENFILENAME.lpstrFile, InStr(OPENFILENAME.lpstrFile, Chr$(0)) - 1)
    End If

End Function