none
如何编写窗体 RRS feed

  • 常规讨论

  • Option Explicit


    '========================================================================================
    ' Form 1.05
    ' 代码编号:000001
    ' http://vbcc.126.com
    ' 版权所有© 2001-2002
    '========================================================================================



    Dim lpwcx As WNDCLASSEX
    Dim RegClass As Long


    Public Function RegWinClass(lpClassName As String)
    '注册窗口类
    With lpwcx
    .cbSize = Len(lpwcx)
    .Style = CS_HREDRAW Or CS_VREDRAW Or CS_DBLCLKS
    .lpszClassName = lpClassName
    .hInstance = App.hInstance
    .cbClsExtra = 0
    .cbWndExtra = 0
    .hCursor = LoadCursor(0, IDC_ARROW)
    .lpfnWndProc = FnPtrToLong(AddressOf MainWinProc)
    .lpszMenuName = 0
    .hbrBackground = COLOR_WINDOW
    End With
    Call RegisterClassEx(lpwcx)
    End Function



    Private Function MainWinProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
    Case WM_DESTROY
    Call PostQuitMessage(0)
    End Select
    MainWinProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
    End Function


    Public Function FnPtrToLong(ByVal lngFnPtr As Long) As Long
    FnPtrToLong = lngFnPtr
    End Function


    ' 创建程序主窗体
    Public Function CreateMainForm(title As String, nWidth As Long, nHeight As Long) As Long
    Dim hWndMain As Long
    Dim lpMsg As MSG

    Call RegWinClass("Form")
    hWndMain = CreateWindowEx(0, "Form", "Windows", WS_OVERLAPPEDWINDOW, 0, 0, nWidth, nHeight, 0, 0, App.hInstance, ByVal 0&)
    '消息循环
    If hWndMain <> 0 Then
    ShowWindow hWndMain, SW_NORMAL
    Do While GetMessage(lpMsg, 0, 0, 0)
    TranslateMessage lpMsg
    DispatchMessage lpMsg
    Loop
    End If
    UnregisterClass "Form", App.hInstance
    End Function


    Public Sub Main()
    CreateMainForm "Windows", 500, 388
    End Sub


    ‘API 声明


    Option Explicit


    ' Window Functions
    Public Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, 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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Public Declare Function LoadResImage Lib "user32" Alias "LoadImageA" (ByVal hinst As Long, ByVal lpsz As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long


    ' Message
    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 RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Integer
    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 Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long


    ' Class Reg And Del
    Public Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long


    '---------------------------------------------------------
    'CreateWindowEx And Dialog Window Style
    '--------------------------------------------------------
    Public Const WS_MINIMIZEBOX = &H20000
    Public Const WS_MAXIMIZEBOX = &H10000
    Public Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
    Public Const WS_OVERLAPPED = &H0&
    Public Const WS_THICKFRAME = &H40000


    Public Const WS_CHILD = &H40000000
    Public Const WS_VISIBLE = &H10000000
    Public Const WS_TABSTOP = &H10000
    Public Const WS_DISABLED = &H8000000
    Public Const WS_SYSMENU = &H80000
    Public Const WS_POPUP = &H80000000
    Public Const WS_GROUP = &H20000


    Public Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)


    ' Window Message
    Public Const WM_TIMER = &H113
    Public Const WM_USER = &H400
    Public Const WM_NOTIFY = &H4E
    Public Const WM_MOUSEMOVE = &H200
    Public Const WM_RBUTTONUP = &H205
    Public Const WM_COMMAND = &H111
    Public Const WM_ENABLE = &HA
    Public Const WM_INITDIALOG = &H110
    Public Const WM_PAINT = &HF
    Public Const WM_CLOSE = &H10
    Public Const WM_CREATE = &H1
    Public Const WM_LBUTTONDOWN = &H201
    Public Const WM_LBUTTONDBLCLK = &H203
    Public Const WM_RBUTTONDBLCLK = &H206
    Public Const WM_RBUTTONDOWN = &H204
    Public Const WM_SIZE = &H5


    Public Const WM_MEASUREITEM = &H2C
    Public Const WM_DRAWITEM = &H2B
    Public Const WM_INITMENUPOPUP = &H117
    Public Const WM_DESTROY = &H2


    ' WNDCLASSEX
    Public Const CS_HREDRAW = &H2
    Public Const CS_VREDRAW = &H1
    Public Const CS_DBLCLKS = &H8


    ' Window Color
    Public Const COLOR_WINDOW = 5


    ' DefSystem Cursor
    Public Const IDC_HAND = 32649&


    ' ShowWindow
    Public Const SW_NORMAL = 1


    Public Const IMAGE_ICON = 1


    ' DefSystem Cursor
    Public Const IDC_ARROW = 32512&


    ' Reg Window
    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
    Times As Long
    pt As POINTAPI
    End Type

    Edited by: LionCSQ
    2009年5月27日 8:13