modlogui.bas

一个把VB原代码转换为VC原代码的软件代码。

Attribute VB_Name = "ModLoGUI"
' -------------------------------------
' VB2Cpp - Visual Basic to C++ translator.
' Copyright (C) 2002-2003 Franck Charlet.
'
' VB2Cpp is free software; you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation; either version 2, or (at your option)
' any later version.
'
' VB2Cpp is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
' GNU General Public License for more details.
'
' You should have received a copy of the GNU General Public License
' along with VB2Cpp; see the file Copying.txt.  If not, write to
' the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
' Boston, MA 02111-1307, USA.
' -------------------------------------
' Low level GUI functions
' -------------------------------------

Option Explicit

' --- Obtain access to common controls and init some required windows objects --- '
Public Sub InitGUIContext(ProcAddress As Long)
    Dim MyCommonStruct As STRUCTINITCOMMONCONTROLSEX
    MyCommonStruct.dwSize = Len(MyCommonStruct)
    MyCommonStruct.dwICC = ICC_WIN95_CLASSES Or ICC_COOL_CLASSES Or ICC_USEREX_CLASSES Or ICC_PAGESCROLLER_CLASS
    If InitCommonControlsEx(MyCommonStruct) = False Then InitCommonControls
    If SerifFont = 0 Then SerifFont = CreateFont(-8, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_SWISS, "MS Sans Serif")
    If CourierFont = 0 Then CourierFont = CreateFont(-12, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_SWISS, "Courier New")
    SetDialogClass App.hInstance, ProcAddress
    SetDumpBoxClass App.hInstance, AddressOf DumpBoxClassProc
    SetColorBoxClass App.hInstance, AddressOf ColorBoxClassProc
End Sub

' --- Reset all --- '
Public Sub ReleaseGUIContext()
    If CourierFont <> 0 Then DeleteObject CourierFont
    If SerifFont <> 0 Then DeleteObject SerifFont
    ' Unregister the classes
    UnregisterClass "VB2CppColorBoxClass", App.hInstance
    UnregisterClass "VB2CppDumpBoxClass", App.hInstance
    UnregisterClass "VB2CppDialogClass", App.hInstance
End Sub

' --- Create a dialog form --- '
Public Function CreateDialog(DLeft As Long, DTop As Long, DWidth As Long, DHeight As Long, hParent As Long, hMenu As Long, hIcon As Long, DTitle As String, WExStyle As Long, WStyle As Long, ShowType As Long) As Long
    Dim ReturnValue As Long
    If DLeft = -1 Then DLeft = (GetSystemMetrics(SM_CXSCREEN) - DWidth) / 2
    If DTop = -1 Then DTop = (GetSystemMetrics(SM_CYSCREEN) - DHeight) / 2
    ReturnValue = CreateWindowEx(WExStyle, "VB2CppDialogClass", DTitle, WS_CLIPSIBLINGS + WStyle, DLeft, DTop, DWidth, DHeight, hParent, hMenu, App.hInstance, ByVal 0)
    If ReturnValue = 0 Then Exit Function
    DialogSetIcon ReturnValue, hIcon
    ShowWindow ReturnValue, ShowType
    UpdateWindow ReturnValue
    CreateDialog = ReturnValue
End Function

' --- Register a standard window class --- '
Private Sub SetDialogClass(hInst As Long, ProcAddress As Long)
    ZeroMemory WinClass, Len(WinClass)
    WinClass.cbSize = Len(WinClass)
    WinClass.style = CS_BYTEALIGNWINDOW Or CS_HREDRAW Or CS_VREDRAW Or CS_BYTEALIGNCLIENT
    WinClass.lpfnwndproc = ProcAddress
    WinClass.cbClsextra = 0
    WinClass.cbWndExtra = 0
    WinClass.hInstance = hInst
    WinClass.hbrBackground = COLOR_BTNFACE + 1
    WinClass.lpszMenuName = ""
    WinClass.lpszClassName = "VB2CppDialogClass"
    WinClass.hIcon = 0
    WinClass.hCursor = LoadCursor(0, IDC_ARROW)
    WinClass.hIconSm = 0
    RegisterClassEx WinClass
End Sub

' --- Register a standard dumpbox class --- '
Private Function SetDumpBoxClass(ByVal hInst As Long, ByVal ProcAddress As Long) As Long
    ZeroMemory WinClass, Len(WinClass)
    WinClass.cbSize = Len(WinClass)
    WinClass.style = CS_BYTEALIGNWINDOW Or CS_HREDRAW Or CS_VREDRAW Or CS_BYTEALIGNCLIENT
    WinClass.lpfnwndproc = ProcAddress
    WinClass.cbClsextra = 0
    WinClass.cbWndExtra = 0
    WinClass.hInstance = hInst
    WinClass.hbrBackground = 0
    WinClass.lpszMenuName = ""
    WinClass.lpszClassName = "VB2CppDumpBoxClass"
    WinClass.hIcon = 0
    WinClass.hCursor = LoadCursor(0, IDC_ARROW)
    WinClass.hIconSm = 0
    SetDumpBoxClass = RegisterClassEx(WinClass)
End Function

' --- Register a standard colorbox class --- '
Private Function SetColorBoxClass(ByVal hInst As Long, ByVal ProcAddress As Long) As Long
    ZeroMemory WinClass, Len(WinClass)
    WinClass.cbSize = Len(WinClass)
    WinClass.style = CS_BYTEALIGNWINDOW Or CS_HREDRAW Or CS_VREDRAW Or CS_BYTEALIGNCLIENT
    WinClass.lpfnwndproc = ProcAddress
    WinClass.cbClsextra = 0
    WinClass.cbWndExtra = 0
    WinClass.hInstance = hInst
    WinClass.hbrBackground = 0
    WinClass.lpszMenuName = ""
    WinClass.lpszClassName = "VB2CppColorBoxClass"
    WinClass.hIcon = 0
    WinClass.hCursor = LoadCursor(0, IDC_HAND)
    WinClass.hIconSm = 0
    SetColorBoxClass = RegisterClassEx(WinClass)
End Function

' --- Set a dialog icon --- '
Public Sub DialogSetIcon(ByVal hwnd As Long, hIcon As Long)
    SendMessage hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon
End Sub

' --- Wait for windows events --- '
Public Function WaitEvents(hAccelerator As Long, hWndAccelerators As Long) As Long
    Do While GetMessage(WinMsg, 0, 0, 0) <> 0
        If TranslateAccelerator(hWndAccelerators, hAccelerator, WinMsg) = 0 Then
            TranslateMessage WinMsg
            DispatchMessage WinMsg
        End If
    Loop
    WaitEvents = WinMsg.wParam
End Function

' --- Create a textbox control --- '
Public Function CreateTextBox(EDLeft As Long, EDTop As Long, EDWidth As Long, EDHeight As Long, hParent As Long, EDText As String, CtrlID As Long, ExtraStyle As Long, ExtraFont As Long, WndProc As Long) As Long
    Dim ExStyle As Long
    Dim ReturnValue As Long
    ControlBound hParent, EDLeft, EDTop, EDWidth, EDHeight
    ExStyle = WS_EX_STATICEDGE
    ReturnValue = CreateWindowEx(ExStyle, "EDIT", EDText, WS_VISIBLE Or WS_CHILD Or ES_LEFT Or ExtraStyle, EDLeft, EDTop, EDWidth, EDHeight, hParent, CtrlID, App.hInstance, ByVal 0)
    If ReturnValue = 0 Then Exit Function
    If ExtraFont <> 0 Then
        ControlSetFont ReturnValue, ExtraFont
    Else
        ControlSetFont ReturnValue, SerifFont
    End If
    If WndProc <> 0 Then SetWindowLong ReturnValue, GWL_USERDATA, SetWindowLong(ReturnValue, GWL_WNDPROC, WndProc)
    CreateTextBox = ReturnValue
End Function

' --- Bound the dimensions of a control --- '
Public Sub ControlBound(hParentControl As Long, ByRef CtlLeft As Long, ByRef CtlTop As Long, ByRef CtlWidth As Long, ByRef CtlHeight As Long)
    Dim WRect As RECT
    GetClientRect hParentControl, WRect
    If CtlTop = -1 Then CtlTop = WRect.top
    If CtlLeft = -1 Then CtlLeft = WRect.left
    If CtlWidth = -1 Then CtlWidth = WRect.Right - CtlLeft
    If CtlHeight = -1 Then CtlHeight = WRect.bottom - CtlTop
End Sub

' --- Display a standard messagebox --- '
Public Function VBMsgBox(hParent As Long, MBText As String, MBType As Long, MBTitle As String) As Long
    If hParent = 0 Then hParent = GetActiveWindow()
    VBMsgBox = MessageBox(hParent, MBText, MBTitle, MBType)
End Function

' --- Set the text of a control --- '
Public Sub ControlSetText(ByVal hwnd As Long, TextToSet As String)
    SendMessage hwnd, WM_SETTEXT, 0, ByVal TextToSet
End Sub

' --- Retrieve a text from a control --- '
Public Function TextBoxGetText(ByVal hwnd As Long) As String
    Dim ReturnValue As String
    Dim TxtSize As Long
    TxtSize = SendMessage(hwnd, WM_GETTEXTLENGTH, 0, ByVal 0)
    If TxtSize > 0 Then
        ReturnValue = String(TxtSize, " ")
        SendMessage hwnd, WM_GETTEXT, TxtSize + 1, ByVal ReturnValue
    End If
    TextBoxGetText = ReturnValue
End Function

' --- Create a statusbar control --- '
Public Function CreateStatusBar(hParent As Long, CtrlID As Long) As Long
    Dim ReturnValue As Long
    ReturnValue = CreateStatusWindow(WS_CHILD Or WS_VISIBLE, "", hParent, CtrlID)
    If ReturnValue = 0 Then Exit Function
    ControlSetFont ReturnValue, SerifFont
    StatusBarSetText ReturnValue, ""
    CreateStatusBar = ReturnValue
End Function

' --- Set control font to standard --- '
Public Sub ControlSetFont(hControl As Long, hFont As Long)
    SendMessage hControl, WM_SETFONT, hFont, ByVal 0
End Sub

' --- Set the text of a part in a statusbar --- '
Public Sub StatusBarSetText(hStatusBar As Long, SBText As String)
    SendMessage hStatusBar, SB_SETTEXT, SBT_NOBORDERS, ByVal SBText
End Sub

' --- Get control height --- '
Public Function GetControlHeight(ByVal hwnd As Long) As Long
    Dim ReturnValue As Long
    Dim CRct As RECT
    GetWindowRect hwnd, CRct
    If IsWindowVisible(hwnd) = 0 Then
        ReturnValue = 0
    Else
        ReturnValue = CRct.bottom - CRct.top
    End If
    GetControlHeight = ReturnValue
End Function

' --- Create a modal dialog form --- '
Public Function CreateModalDialog(DWidth As Long, DHeight As Long, hParent As Long, WinProc As Long, ExtraStyle As Long) As Long
    Dim BaseDialogX As Long
    Dim BaseDialogY As Long
    BaseDialogX = GetDialogBaseUnits And &HFFFF&
    BaseDialogY = (GetDialogBaseUnits And &HFFFF0000) \ &H10000
    DialogTemplate.dwExtendedStyle = 0
    DialogTemplate.X = 0
    DialogTemplate.Y = 0
    DialogTemplate.cx = (DWidth * 4) \ BaseDialogX
    DialogTemplate.cy = (DHeight * 8) \ BaseDialogY
    DialogTemplate.style = 4 Or WS_VISIBLE Or DS_3DLOOK Or DS_NOIDLEMSG Or DS_SETFOREGROUND Or DS_MODALFRAME Or ExtraStyle Or DS_CENTER
    DialogTemplate.cdit = 0
    CreateModalDialog = DialogBoxIndirectParam(App.hInstance, DialogTemplate, hParent, WinProc, 0)
End Function

' --- Create a checkbox control --- '
Public Function CreateCheckBox(BLeft As Long, BTop As Long, BWidth As Long, BHeight As Long, hParent As Long, BText As String, CtrlID As Long, ExtraStyle As Long) As Long
    Dim ReturnValue As Long
    ControlBound hParent, BLeft, BTop, BWidth, BHeight
    ReturnValue = CreateWindowEx(0, "BUTTON", BText, WS_TABSTOP Or WS_VISIBLE Or WS_CHILD Or BS_LEFT Or BS_VCENTER Or BS_AUTOCHECKBOX Or BS_MULTILINE Or ExtraStyle, BLeft, BTop, BWidth, BHeight, hParent, CtrlID, App.hInstance, ByVal 0)
    If ReturnValue = 0 Then Exit Function
    ControlSetFont ReturnValue, SerifFont
    CreateCheckBox = ReturnValue
End Function

' --- Create a label control --- '
Public Function CreateLabel(LLeft As Long, LTop As Long, LWidth As Long, LHeight As Long, hParent As Long, LText As String, CtrlID As Long, ExtraStyle As Long) As Long
    Dim ReturnValue As Long
    ControlBound hParent, LLeft, LTop, LWidth, LHeight
    ReturnValue = CreateWindowEx(0, "STATIC", LText, WS_VISIBLE Or WS_CHILD Or SS_LEFT + ExtraStyle, LLeft, LTop, LWidth, LHeight, hParent, CtrlID, App.hInstance, ByVal 0)
    If ReturnValue = 0 Then Exit Function
    ControlSetFont ReturnValue, SerifFont
    CreateLabel = ReturnValue
End Function

' --- Choose a file to open --- '
Public Function ChooseOpenFile(hwnd As Long, OFilters As String, InitDir As String, MultiSelect As Boolean) As String
    Dim TmpOp As String
    Dim i As Long
    Dim LocFilters As Long
    MyOpenFName.lStructSize = Len(MyOpenFName)
    MyOpenFName.hwndOwner = hwnd
    MyOpenFName.flags = OFN_EXPLORER + OFN_HIDEREADONLY + OFN_SHOWHELP + OFN_PATHMUSTEXIST + OFN_FILEMUSTEXIST + OFN_LONGNAMES
    If MultiSelect = True Then MyOpenFName.flags = MyOpenFName.flags Or OFN_ALLOWMULTISELECT
    MyOpenFName.lpstrDefExt = ""
    MyOpenFName.lpstrInitialDir = InitDir
    ' Avoid using Chr(0) at all costs
    MyOpenFName.lpstrFile = String(256, " ")
    ZeroMemory ByVal MyOpenFName.lpstrFile, 1