mdlmenu.bas

来自「本系统可用于医院和专业体检中心的健康体检管理」· BAS 代码 · 共 224 行

Attribute VB_Name = "mdlMenu"
Option Explicit
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuString Lib "user32" Alias "GetMenuStringA" (ByVal hMenu As Long, ByVal wIDItem As Long, ByVal lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Const MF_BYPOSITION = &H400&
Private Const BUFFER_SIZE = 256
Private m_strExecString() As String
Private m_lngAppWinStyle() As VbAppWinStyle
Private m_lngPluginHWnd() As Long
Private m_intIndex As Long

Private Declare Function EbExecuteLine Lib "vba6.dll" (ByVal pStringToExec As Long, ByVal Unknownn1 As Long, ByVal Unknownn2 As Long, ByVal fCheckOnly As Long) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

Private Const WM_CLOSE = &H10
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDFIRST = 0
Private Handler(200) As Integer

Private Function ExecuteLine(sCode As String, Optional fCheckOnly As Boolean) As Boolean
    ExecuteLine = EbExecuteLine(StrPtr(sCode), 0&, 0&, Abs(fCheckOnly)) = 0
End Function

Public Sub ClearMultiSeperator(ByVal hForm As Long)
    Dim hMenuHWnd As Long
    Dim intMenuCount As Integer
    Dim intSubMenuCount As Integer
    Dim hSubMenuHWnd As Long
    Dim i As Integer, j As Integer
    Dim strBuffer As String
    Dim blnIsSeperator As Boolean
    Dim blnIsLast As Boolean
    
    hMenuHWnd = GetMenu(hForm)
    intMenuCount = GetMenuItemCount(hMenuHWnd)
    
    For i = 0 To intMenuCount - 1
        hSubMenuHWnd = GetSubMenu(hMenuHWnd, i)
        intSubMenuCount = GetMenuItemCount(hSubMenuHWnd)
        
        blnIsSeperator = False '初始化
        blnIsLast = True
        For j = intSubMenuCount - 1 To 0 Step -1
            strBuffer = String(BUFFER_SIZE, Chr(0))
            Call GetMenuString(hSubMenuHWnd, j, strBuffer, BUFFER_SIZE + 1, MF_BYPOSITION)
            strBuffer = Left(strBuffer, InStr(1, strBuffer, Chr(0)) - 1)
            
            If strBuffer = "" Then
                If blnIsLast Or (j = 0) Then
                    If (Not blnIsLast) And blnIsSeperator Then
                        Call DeleteMenu(hSubMenuHWnd, j + 1, MF_BYPOSITION)
                    End If
                    Call DeleteMenu(hSubMenuHWnd, j, MF_BYPOSITION)
                ElseIf blnIsSeperator Then
                    Call DeleteMenu(hSubMenuHWnd, j + 1, MF_BYPOSITION)
                Else
                    blnIsSeperator = True
                End If
            Else
                blnIsSeperator = False
                blnIsLast = False
            End If
        Next j
    Next i
End Sub

'加载菜单
Private Function AppendMenuW(ByRef mnuName As Variant, _
        ByVal strMenuCaption As String) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim intCurrentCount As Integer
    
    Load mnuName(mnuName.Count)
    mnuName(mnuName.Count - 1).Caption = strMenuCaption
    mnuName(mnuName.Count - 1).Visible = True
    
    AppendMenuW = True
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Function

'处理插件
Public Function DisposePlugin(ByRef mnuName As Variant) As Boolean
On Error Resume Next
    Dim strFile As String
    Dim lngPluginCount As Long
    Dim i As Long, K As Long
    Dim strExeName As String
    Dim strCaption As String
    Dim strAppendExe As String
    Dim strWinStyle As String
    
    strFile = gstrCurrPath & PluginDir & PluginFile
    If Dir(strFile) = "" Then GoTo ExitLab
    
    lngPluginCount = CLng(Val(GetINI(strFile, "PluginSet", "PluginNumber", "")))
    If lngPluginCount < 1 Then GoTo ExitLab
    
    '循环所有插件
    K = 1
    For i = 1 To lngPluginCount
        strExeName = GetINI(strFile, "Plugin" & CStr(i), "FileName", "")
        If strExeName <> "" Then
            If Mid(strExeName, 2, 1) <> ":" Then strExeName = gstrCurrPath & PluginDir & strExeName
            If Dir(strExeName) <> "" Then
                strCaption = GetINI(strFile, "Plugin" & CStr(i), "Caption", "")
                If strCaption <> "" Then
                    ReDim Preserve m_strExecString(K)
                    ReDim Preserve m_lngAppWinStyle(K)
                    
                    strAppendExe = GetINI(strFile, "Plugin" & CStr(i), "ExecString", "")
                    If strAppendExe = "" Then
                        m_strExecString(K) = strExeName
                    Else
                        m_strExecString(K) = strAppendExe
                    End If
                    
                    'Window Style
                    strWinStyle = GetINI(strFile, "Plugin" & CStr(i), "WindowStyle", "")
                    Select Case strWinStyle
                        Case "Hide", "0"
                            m_lngAppWinStyle(K) = vbHide
                        Case "NormalFocus", "1"
                            m_lngAppWinStyle(K) = vbNormalFocus
                        Case "MinimizedFocus", "2"
                            m_lngAppWinStyle(K) = vbMinimizedFocus
                        Case "MaximizedFocus", "3"
                            m_lngAppWinStyle(K) = vbMaximizedFocus
                        Case "NormalNoFocus", "4"
                            m_lngAppWinStyle(K) = vbNormalNoFocus
                        Case "MinimizeNoFocus", "6"
                            m_lngAppWinStyle(K) = vbMinimizedNoFocus
                        Case Else
                            m_lngAppWinStyle(K) = vbNormalFocus
                    End Select
                    
                    '加挂菜单
                    Call AppendMenuW(mnuName, strCaption)
                    
                    K = K + 1
                End If
            End If
        End If
    Next i
    
    GoTo ExitLab:
ExitLab:
    '
End Function

Public Sub ClickPluginMenu(ByVal intIndex As Integer, ByVal lngHWnd As Long)
On Error GoTo ErrMsg
    Call Shell(m_strExecString(intIndex) & " " & COMMUNICATION_STRING_PLUGIN & " " & lngHWnd, m_lngAppWinStyle(intIndex))
    
    GoTo ExitLab
ErrMsg:
    MsgBox "Error " & Err.Number & " in " & Err.Source & ":" _
            & vbCrLf & Err.Description, vbExclamation, "提示"
ExitLab:
    '
End Sub

'退出时向各插件发送关闭指令
Public Sub SendCloseMessageToAllPlugin(ByVal lngParentHWnd As Long)
    Dim i As Integer
    
    Call FindRunningPlugin(lngParentHWnd)
    If m_intIndex > 0 Then
        For i = 1 To UBound(m_lngPluginHWnd)
            Call SendMessage(m_lngPluginHWnd(i), WM_CLOSE, 0, 0)
'            Call TerminateProcess(m_lngPluginHWnd(i), 0)
        Next
    End If
End Sub

Public Function FindRunningPlugin(ByVal lngBeginHWnd As Long) As Long
    Dim lngRenHWND As Long
    Dim intCount As Integer
    Dim lngRetValue As Long
    Dim lngWinTextLength As Long
    Dim strWinText As String
    Dim strWinTitle As String
    Dim i As Integer
    Dim strPluginTitle(1 To 1) As String
    
    intCount = 0
    
    strPluginTitle(1) = "RIS连接工具"
    
    lngRenHWND = GetWindow(lngBeginHWnd, GW_HWNDFIRST)
    Do
        strWinText = String(256, Chr(0))
        lngRetValue = GetWindowText(lngRenHWND, strWinText, 256)
        If lngRetValue <> 0 Then
            strWinTitle = Left(strWinText, InStr(1, strWinText, Chr(0)) - 1)
            
            For i = LBound(strPluginTitle) To UBound(strPluginTitle)
                If strWinTitle = strPluginTitle(i) Then
                    m_intIndex = m_intIndex + 1
                    ReDim Preserve m_lngPluginHWnd(m_intIndex)
                    
                    m_lngPluginHWnd(m_intIndex) = lngRenHWND
                    Exit For
                End If
            Next i
        End If
        lngRenHWND = GetWindow(lngRenHWND, GW_HWNDNEXT)
    Loop Until lngRenHWND = 0
End Function