mainwnd.bas

VB用标准模块创建RPG游戏窗口

Attribute VB_Name = "MainWnd"
'======================================================================================
'程 序 名: 用模块创建RPG游戏窗口
'版    本: V1.0
'开发人员: 随风の追梦
'公    司: 随风工作室
'创建时间: 2008-11-9 16:40
'修改时间: ----
'完成时间: 2008-11-9 16:55
'邮    箱: [e-mail]
'======================================================================================
Option Explicit
Private 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
'创建窗口
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
'显示窗口
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
'装载光标
Private Declare Function LoadIcon Lib "user32" Alias "LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As Long) As Long
'装载图标
Private 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
'默认窗口处理
Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
'将键盘的虚拟键消息转化为字符消息
Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
'发送消息
Private Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long)
'退出程序
Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
'获取消息
Private Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Long
'注册窗口类
Private Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long
'撤消窗口类注册
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
'拷贝内存
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'获取系统规则
Private Type POINTAPI
        x               As Long
        y               As Long
End Type
Private Type MSG
        hWnd            As Long
        message         As Long
        wParam          As Long
        lParam          As Long
        time            As Long
        pt              As POINTAPI
End Type
Private 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
Private Const SM_CXSCREEN = &H0
Private Const SM_CYSCREEN = &H1
Private Const IDI_APPLICATION = &H7F00
Private Const IDC_ARROW = &H7F00
Private Const CS_DBLCLKS = &H8
Private Const COLOR_WINDOW = &H6
Private Const WM_DESTROY = &H2
Private Const WS_GAMEWINDOW = &HCA0000
Private Const SW_SHOWNORMAL = &H1
Private Const HWND_DESKTOP = &H0
Private Const szGameWndClass = "RPGGameClass"
Private Const szGameWndName = "RPGGame V1.0"
'--------------------------------------------------------------------------------------
Private Sub Main()
        Dim lpMsg As MSG
        Dim lpWndClass As WNDCLASSEX
        Dim hMainWnd As Long
        With lpWndClass
             .cbSize = Len(lpWndClass)                                          'lpWndClass结构大小
             .lpszClassName = szGameWndClass                                    '窗口类名
             .hIcon = LoadIcon(0, IDI_APPLICATION)                              '设置桌面图标
             .hIconSm = LoadIcon(0, IDI_APPLICATION)                            '设置标题栏图标
             .hCursor = LoadCursor(0, IDC_ARROW)                                '设置光标
             .hbrBackground = COLOR_WINDOW                                      '窗口背景画刷句柄
             .hInstance = App.hInstance                                         '实例句柄
             .lpszMenuName = vbNullString                                       '菜单名
             .style = CS_DBLCLKS                                                '类样式
             .lpfnWndProc = GetAddress(AddressOf MainWndProc)                   '窗口处理函数地址
             .cbClsExtra = 0                                                    '类字节
             .cbWndExtra = 0                                                    '窗口字节
        End With
        If RegisterClassEx(lpWndClass) = 0 Then Exit Sub                        '注册窗口类(如果类已注册,则退出)
        hMainWnd = CreateWindowEx(0, szGameWndClass, szGameWndName, WS_GAMEWINDOW, _
        (GetSystemMetrics(SM_CXSCREEN) - 800) / 2, (GetSystemMetrics(SM_CYSCREEN) - 600) / 2, _
        800, 600, HWND_DESKTOP, 0, App.hInstance, ByVal 0)                      '创建窗口(窗口居中)
        Call ShowWindow(hMainWnd, SW_SHOWNORMAL)                                '显示窗口
        Do While GetMessage(lpMsg, 0, 0, 0)                                     '获取系统消息
           Call TranslateMessage(lpMsg)                                         '将键盘的虚拟键消息转化为字符消息
           Call DispatchMessage(lpMsg)                                          '将系统消息放入窗口消息队列
        Loop
        Call UnregisterClass(szGameWndClass, App.hInstance)                     '撤消窗口类注册
End Sub
'--------------------------------------------------------------------------------------
Private Function MainWndProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Select Case wMsg
               Case WM_DESTROY                                                  '消毁窗口
                    Call PostQuitMessage(0)                                     '向每一个子窗口发送一条退出消息
               Case Else
                    MainWndProc = DefWindowProc(hWnd, wMsg, wParam, lParam)     '默认窗口消息处理(由系统自动处理)
        End Select
End Function
'--------------------------------------------------------------------------------------
Private Function GetAddress(ByVal lAddress As Long) As Long
        GetAddress = lAddress
End Function