modmain.bas

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

Attribute VB_Name = "ModMain"
' -------------------------------------
' 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.
' -------------------------------------
' Example 3
' Display a simple dialog
' -------------------------------------

Option Explicit

' --- System Constants --- '
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)

Public Const IDC_ARROW = 32512

Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1

Public Const WS_CLIPSIBLINGS = &H4000000

Public Const WS_THICKFRAME = &H40000
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_SYSMENU = &H80000
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_SIZEBOX = WS_THICKFRAME

Public Const CS_BYTEALIGNWINDOW = &H2000
Public Const CS_HREDRAW = &H2
Public Const CS_VREDRAW = &H1
Public Const CS_BYTEALIGNCLIENT = &H1000&

Public Const SW_SHOW = 5

Public Const WM_CREATE = &H1&
Public Const WM_CLOSE = &H10&
Public Const WM_DESTROY = &H2&

Public Const COLOR_BTNFACE = 15

' --- System types --- '
Public Type WNDCLASSEX
    cbSize As Long
    style As Long
    lpfnwndproc As Long
    cbClsextra As Long
    cbWndExtra As Long
    hInstance As Long
    hIcon As Long
    hCursor As Long
    hbrBackground As Long
    lpszMenuName As String
    lpszClassName As String
    hIconSm As Long
End Type

Public Type POINTAPI
    x As Long
    y As Long
End Type

Public Type MSG
    hwnd As Long
    Message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

' --- System functions --- '
Public Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As Any, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Public Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Public Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
Public Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Public Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Integer
Public Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long)

Public Sub Main()
    Dim WinHandle As Long
    WASetDialogClass 0
    WinHandle = CreateDialog(-1, -1, 300, 300, 0, 0, 0, "Dialog converted from Visual Basic", 0, 0, WS_MAXIMIZEBOX Or WS_SYSMENU Or WS_SIZEBOX Or WS_MINIMIZEBOX, SW_SHOW)
    WaitEvents
End Sub

' --- Default class hook for dialog --- '
Private Function DefClassHook(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case WM_CREATE
            DefClassHook = 0
            Exit Function
        Case WM_CLOSE
            DestroyWindow hwnd
        Case WM_DESTROY
            PostQuitMessage 0
    End Select
    DefClassHook = DefWindowProc(hwnd, uMsg, wParam, lParam)
End Function

' --- 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, WinProc As Long, WExStyle As Long, WStyle As Long, ShowType As Long) As Long
    If DLeft = -1 Then DLeft = (GetSystemMetrics(SM_CXSCREEN) - DWidth) \ 2
    If DTop = -1 Then DTop = (GetSystemMetrics(SM_CYSCREEN) - DHeight) \ 2
    CreateDialog = CreateWindowEx(WExStyle, "VBDialogClass", DTitle, WS_CLIPSIBLINGS + WStyle, DLeft, DTop, DWidth, DHeight, hparent, hMenu, 0, ByVal 0)
    If CreateDialog = 0 Then Exit Function
    ShowWindow CreateDialog, ShowType
    UpdateWindow CreateDialog
End Function

' --- Register a standard window class --- '
Private Sub WASetDialogClass(hInst As Long)
    Dim MyClass As WNDCLASSEX
    MyClass.cbSize = Len(MyClass)
    MyClass.style = CS_BYTEALIGNWINDOW Or CS_HREDRAW Or CS_VREDRAW Or CS_BYTEALIGNCLIENT
    MyClass.lpfnwndproc = VBGetAddressProc(AddressOf DefClassHook)
    MyClass.cbClsextra = 0
    MyClass.cbWndExtra = 0
    MyClass.hInstance = hInst
    MyClass.hbrBackground = COLOR_BTNFACE + 1
    MyClass.lpszMenuName = ""
    MyClass.lpszClassName = "VBDialogClass"
    MyClass.hIcon = 0
    MyClass.hCursor = LoadCursor(0, IDC_ARROW)
    MyClass.hIconSm = 0
    RegisterClassEx MyClass
End Sub

' --- Register a class procedure (VB trick) --- '
Public Function VBGetAddressProc(Addr As Long) As Long
    VBGetAddressProc = Addr
End Function

' --- Wait for incoming messages --- '
Public Function WaitEvents() As Long
    Dim LoopMsg As MSG
    Do While GetMessage(LoopMsg, 0, 0, 0) <> 0
        TranslateMessage LoopMsg
        DispatchMessage LoopMsg
    Loop
    WaitEvents = LoopMsg.wParam
End Function