VisualBasic 6.0

tricky.bas

Attribute VB_Name = "mdlMain"
Option Explicit
'
'     tricky.bas
'
' Copyright(c) 2001 yoh(yohhoy)
'

' Win32API
Private Type WNDCLASS
    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
End Type
Private Type MSG
    hwnd    As Long
    message As Long
    wParam  As Long
    lParam  As Long
    time    As Long
    pt_x    As Long 'pt.x
    pt_y    As Long 'pt.y
End Type

Private Declare Function RegisterClass Lib "user32" Alias "RegisterClassA" (Class As WNDCLASS) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As Long) As Long
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 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 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 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 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 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 CreateMenu Lib "user32" () As Long
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long

Private Const WM_CREATE  As Long = &H1
Private Const WM_DESTROY As Long = &H2
Private Const WM_CLOSE   As Long = &H10
Private Const WM_COMMAND As Long = &H111
Private Const CS_VREDRAW As Long = &H1
Private Const CS_HREDRAW As Long = &H2
Private Const IDI_APPLICATION As Long = 32512
Private Const IDC_ARROW As Long = 32512
Private Const COLOR_BTNFACE As Long = 15
Private Const WS_OVERLAPPED As Long = &H0
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_THICKFRAME  As Long = &H40000
Private Const WS_SYSMENU     As Long = &H80000
Private Const WS_CAPTION     As Long = &HC00000
Private Const WS_OVERLAPPEDWINDOW As Long = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Private Const CW_USEDEFAULT As Long = &H80000000
Private Const SW_SHOW As Long = 5
Private Const MF_STRING As Long = &H0
Private Const MF_POPUP  As Long = &H10

' module variable
Private m_hInstance As Long

Private Const WNDCLSNAME As String = "TrickyVbWndCls"
Private Const IDM_EXIT = 1


Public Sub Main()
    Dim wc As WNDCLASS
    Dim hMenu As Long, hSubMenu As Long
    Dim hwnd As Long
    Dim message As MSG
    
    '初期化
    m_hInstance = GetModuleHandle(0)
    
    'ウインドウクラスを登録
    With wc
        .style = CS_VREDRAW Or CS_HREDRAW
        .lpfnWndProc = funcaddr(AddressOf WindowProc)
        .cbClsExtra = 0
        .cbWndExtra = 0
        .hinstance = m_hInstance
        .hIcon = LoadIcon(0, IDI_APPLICATION)
        .hCursor = LoadCursor(0, IDC_ARROW)
        .hbrBackground = COLOR_BTNFACE + 1
        .lpszMenuName = vbNullString
        .lpszClassName = WNDCLSNAME
    End With
    Call RegisterClass(wc)
    
    'メニュー作成
    hMenu = CreateMenu()
    hSubMenu = CreatePopupMenu()
    Call AppendMenu(hMenu, MF_STRING Or MF_POPUP, hSubMenu, "&File")
    Call AppendMenu(hSubMenu, MF_STRING, IDM_EXIT, "&Exit")
    
    'ウインドウ作成
    hwnd = CreateWindowEx(0, WNDCLSNAME, "tricky", _
                          WS_OVERLAPPEDWINDOW, _
                          CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
                          0, hMenu, m_hInstance, 0)
    Call ShowWindow(hwnd, SW_SHOW)
    
    'メッセージループ
    Do While (GetMessage(message, 0, 0, 0))
        Call TranslateMessage(message)
        Call DispatchMessage(message)
    Loop
    
    'メニュー破棄
    Call DestroyMenu(hSubMenu)
    Call DestroyMenu(hMenu)

End Sub

'
' ウインドウプロシージャ
'
Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    
    WindowProc = 0
    
    Select Case uMsg
    Case WM_CREATE
        '
    
    Case WM_COMMAND
        Select Case (wParam And &HFFFF)
        Case IDM_EXIT '[Exit]
            'ウインドウを閉じる
            Call SendMessage(hwnd, WM_CLOSE, 0, 0)
        End Select
    
    Case WM_DESTROY
        'アプリケーション終了
        Call PostQuitMessage(0)
    
    Case Else
        WindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
    
    End Select

End Function


Private Function funcaddr(ByVal addr As Long) As Long
    funcaddr = addr
End Function

tricky.vbp

Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\SYSTEM\StdOle2.Tlb#OLE Automation
Module=mdlMain; tricky.bas
Startup="Sub Main"
HelpFile=""
Title="tricky"
ExeName32="tricky.exe"
Command32=""
Name="tricky"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionFileDescription="tricky VB program"
VersionLegalCopyright="Copyright(c) 2001 yoh(yohhoy)"
CompilationType=-1
OptimizationType=1
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=-1
BoundsCheck=-1
OverflowCheck=-1
FlPointCheck=-1
FDIVCheck=-1
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
DebugStartupOption=0