'お待ち下さいダイアログボックスのサンプルマクロ

'一番下に利用サンプルがあります。

Option Explicit

'************************
' Win32 API
'************************

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type SIZE
    cx As Long
    cy As Long
End Type

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


'************************
' Constants
'************************

Private Const GWL_HINSTANCE = (-6)
Private Const GWW_HINSTANCE = (-6)
Private Const WS_CAPTION As Long = &hc00000
Private Const SS_BLACKFRAME As Long = &h7
Private Const WS_CHILD As Long = &h40000000
Private Const SW_HIDE = 0
Private Const SW_SHOW = 5
Private Const SW_SHOWNOACTIVATE = 4

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90

Private Const ETO_CLIPPED = 4
Private Const ETO_OPAQUE = 2

Private Const PM_REMOVE = &h1
Private Const WM_KEYFIRST = &h100
Private Const WM_KEYLAST = &h108
Private Const WM_KEYDOWN = &h100


Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
    ByVal hwnd As Long, ByVal nIndex 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 Any, _
    ByVal hinstance As Long, ByVal lpParam As Long) As Long

Private Declare Function DestroyWindow Lib "user32" ( _
    ByVal hwnd As Long) As Long

Private Declare Function ShowWindow Lib "user32" ( _
    ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function UpdateWindow Lib "user32" ( _
    ByVal hwnd As Long) As Long

Private Declare Function GetSystemMetrics Lib "user32" ( _
    ByVal nIndex As Long) As Long

Private Declare Function GetClientRect Lib "user32" ( _
    ByVal hwnd As Long, ByRef lprc As RECT) As Long

Private Declare Function GetDC Lib "user32" ( _
    ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
    ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" ( _
    ByVal hdc As Long, ByVal lpString As String, _
    ByVal cbCount As Long, ByRef lpSize As SIZE) As Long

Private Declare Function SetTextColor Lib "gdi32" ( _
    ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" ( _
    ByVal hdc As Long, ByVal crColor As Long) As Long

Private Declare Function ExtTextOut Lib "gdi32" Alias "ExtTextOutA" ( _
    ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
    ByVal fuOptions As Long, ByRef lprc As RECT, _
    ByVal lpString As String, ByVal cbCount As Long, _
    ByVal lpDx As Long) As Long

Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" ( _
    lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, _
    ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long


'************************
' Win16 API
'************************

Private Type RECT16
    Left As Integer
    Top As Integer
    Right As Integer
    Bottom As Integer
End Type

Private Type SIZE16
    cx As Integer
    cy As Integer
End Type

Private Declare Function FindWindow16 Lib "user" Alias "FindWindow" ( _
    ByVal lpClassName As String, ByVal lpWindowName As String) As Integer

Private Declare Function GetWindowWord16 Lib "user" Alias "GetWindowWord" ( _
    ByVal hwnd As Integer, ByVal nIndex As Integer) As Integer

Private Declare Function CreateWindowEx16 Lib "user" Alias "CreateWindowEx" ( _
    ByVal dwExStyle As Long, ByVal lpClassName As String, _
    ByVal lpWindowName As String, ByVal dwStyle As Long, _
    ByVal x As Integer, ByVal y As Integer, _
    ByVal nWidth As Integer, ByVal nHeight As Integer, _
    ByVal hwndParent As Integer, ByVal hmenu As Integer, _
    ByVal hinstance As Integer, ByVal lpParam As Long) As Long

Private Declare Function DestroyWindow16 Lib "user" Alias "DestroyWindow" ( _
    ByVal hwnd As Integer) As Integer

Private Declare Function ShowWindow16 Lib "user" Alias "ShowWindow" ( _
    ByVal hwnd As Integer, ByVal nCmdShow As Integer) As Integer

Private Declare Function UpdateWindow16 Lib "user" Alias "UpdateWindow" ( _
    ByVal hwnd As Integer) As Integer

Private Declare Function GetSystemMetrics16 Lib "user" Alias "GetSystemMetrics" ( _
    ByVal nIndex As Long) As Integer

Private Declare Function GetClientRect16 Lib "user" Alias "GetClientRect" ( _
    ByVal hwnd As Integer, ByRef lprc As RECT16) As Integer

Private Declare Function GetDC16 Lib "user" Alias "GetDC" ( _
    ByVal hwnd As Integer) As Integer
Private Declare Function ReleaseDC16 Lib "user" Alias "ReleaseDC" ( _
    ByVal hwnd As Integer, ByVal hdc As Integer) As Integer

Private Declare Function GetTextExtentPoint16 Lib "gdi" Alias "GetTextExtentPoint" ( _
    ByVal hdc As Integer, ByVal lpString As String, _
    ByVal cbCount As Integer, ByRef lpSize As SIZE16) As Integer

Private Declare Function SetTextColor16 Lib "gdi" Alias "SetTextColor" ( _
    ByVal hdc As Integer, ByVal crColor As Long) As Integer
Private Declare Function SetBkColor16 Lib "gdi" Alias "SetBkColor" ( _
    ByVal hdc As Integer, ByVal crColor As Long) As Integer

Private Declare Function ExtTextOut16 Lib "gdi" Alias "ExtTextOut" ( _
    ByVal hdc As Integer, ByVal x As Integer, ByVal y As Integer, _
    ByVal fuOptions As Integer, ByRef lprc As RECT16, _
    ByVal lpString As String, ByVal cbCount As Integer, _
    ByVal lpDx As Long) As Integer


'************************
' Variables
'************************

'Public Fields
Public sWindowText As String

'Private Fields
Private hwnd As Long
Private hwnd_Bar As Long

Private hwnd16 As Long
Private hwnd_Bar16 As Long

Private iBarWidth As Integer
Private iBarHeight As Integer

Private iValue As Integer

Private iVersion As Integer
Private iOS As Integer


'************************
' Public Function
'************************

Public Function DLGW_Show() As Boolean
    Dim sOS As String
    Dim sVersion As String

    iValue = -1

    sOS = Application.OperatingSystem
    If sOS Like "*Windows*" Then
        If sOS Like "*32*" Then
            iOS = 32
        Else
            iOS = 16
        End If
    Else
        iOS = 0
    End If

    sVersion = Application.Version
    If sVersion Like "8.*" Then
        iVersion = 800
    ElseIf sVersion Like "7.*" Then
        iVersion = 700
    ElseIf sVersion Like "5.*" Then
        iVersion = 500
    Else
        iVersion = 0
    End If

    Select Case iOS
        Case 32
            DLGW_Show = Form_Show()
        Case 16
            DLGW_Show = Form_Show16()
    End Select
End Function

Public Sub DLGW_Free()
    Select Case iOS
        Case 32
            Form_Hide
        Case 16
            Form_Hide16
    End Select
End Sub

Public Property Let DLGW_Value(ByVal iArg As Integer)

    If iArg = iValue Then Exit Property
    iValue = iArg

    If iVersion = 700 Then
        If IsCancel() Then Error 18
    End If

    Select Case iOS
        Case 32
            DrawBar iArg
        Case 16
            DrawBar16 iArg
    End Select
End Property


'************************
' Private Function Win32
'************************

Private Function Form_Show() As Boolean
    Dim hwnd_p As Long
    Dim hinst_p As Long
    Dim rc As RECT
    Dim cx As Long, cy As Long
    Dim iLeft As Long, iTop As Long
    Dim iWidth As Long, iHeight As Long
    Dim iRet As Long

    If hwnd <> 0 Then Exit Function

    iWidth = 320
    iHeight = 90

    cx = GetSystemMetrics(SM_CXSCREEN)
    cy = GetSystemMetrics(SM_CYSCREEN)
    iLeft = (cx - iWidth) \ 2
    iTop = (cy - iHeight) \ 2

    hwnd_p = FindWindow("XLMAIN", Application.Caption)
    hinst_p = GetWindowLong(hwnd_p, GWL_HINSTANCE)

    hwnd = CreateWindowEx(0, "#32770", sWindowText, _
        WS_CAPTION, iLeft, iTop, iWidth, iHeight, _
        hwnd_p, 0&, hinst_p, 0&)

    iRet = GetClientRect(hwnd, rc)

    hwnd_Bar = CreateWindowEx(0, "Static", "", _
        WS_CHILD Or SS_BLACKFRAME, 8, 16, rc.Right - 16, 24, _
        hwnd, 0&, hinst_p, 0&)

    iBarWidth = rc.Right - 18
    iBarHeight = 22

    iRet = ShowWindow(hwnd_Bar, SW_SHOWNOACTIVATE)
    iRet = ShowWindow(hwnd, SW_SHOW)
    iRet = UpdateWindow(hwnd_Bar)
    iRet = UpdateWindow(hwnd)
    Form_Show = True
End Function

Private Function Form_Hide() As Boolean
    Dim iRet As Long
    If hwnd <> 0 Then
        iRet = ShowWindow(hwnd, SW_HIDE)
        iRet = DestroyWindow(hwnd)
        hwnd = 0
        hwnd_Bar = 0
    End If
    Form_Hide = True
End Function

Private Function DrawBar(ByVal iArg As Integer) As Boolean
    Dim hdc As Long
    Dim rc As RECT, rc_Left As RECT, rc_Right As RECT
    Dim sz As SIZE
    Dim x As Long, y As Long
    Dim iRet As Long
    Dim sText As String

    If hwnd = 0 Then Exit Function

    If iArg < 0 Or iArg > 100 Then Exit Function

    sText = CStr(iArg) & "%"

    With rc_Left
        .Left = 1
        .Top = 1
        .Right = (CLng(iBarWidth) * iArg) \ 100 + 1
        .Bottom = iBarHeight + 1
    End With

    With rc_Right
        .Left = rc_Left.Right
        .Top = 1
        .Right = iBarWidth + 1
        .Bottom = iBarHeight + 1
    End With

    hdc = GetDC(hwnd_Bar)

    iRet = GetTextExtentPoint32(hdc, sText, Len(sText), sz)
    x = (iBarWidth - sz.cx) \ 2 + 1
    y = (iBarHeight - sz.cy) \ 2 + 1

    iRet = SetBkColor(hdc, &hff0000)
    iRet = SetTextColor(hdc, &hffffff)
    iRet = ExtTextOut(hdc, x, y, ETO_CLIPPED Or ETO_OPAQUE, _
            rc_Left, sText, Len(sText), 0&)

    iRet = SetTextColor(hdc, &h0)
    iRet = SetBkColor(hdc, &hffffff)
    iRet = ExtTextOut(hdc, x, y, ETO_CLIPPED Or ETO_OPAQUE, _
        rc_Right, sText, Len(sText), 0&)

    iRet = ReleaseDC(hwnd_Bar, hdc)

    DrawBar = True
End Function


Private Function IsCancel() As Boolean
    Dim msg1 As MSG
    Dim iRet As Long
    Dim i As Integer

    For i = 1 To 20
        If PeekMessage(msg1, 0&, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE) <> 0 Then
            If msg1.message = WM_KEYDOWN Then
                Select Case msg1.wParam
                    Case 3, 27
                        IsCancel = True
                        Exit Function
                End Select
            End If
            iRet = TranslateMessage(msg1)
        Else
            Exit For
        End If
    Next
    IsCancel = False
End Function


'************************
' Private Function Win16
'************************

Private Function Form_Show16() As Boolean
    Dim hwnd_p As Integer
    Dim hinst_p As Integer
    Dim rc As RECT16
    Dim cx As Integer, cy As Integer
    Dim iLeft As Integer, iTop As Integer
    Dim iWidth As Integer, iHeight As Integer
    Dim iRet As Integer

    If hwnd16 <> 0 Then Exit Function

    iWidth = 320
    iHeight = 90

    cx = GetSystemMetrics16(SM_CXSCREEN)
    cy = GetSystemMetrics16(SM_CYSCREEN)
    iLeft = (cx - iWidth) \ 2
    iTop = (cy - iHeight) \ 2

    hwnd_p = FindWindow16("XLMAIN", Application.Caption)
    hinst_p = GetWindowWord16(hwnd_p, GWW_HINSTANCE)

    hwnd16 = CreateWindowEx16(1, "#32770", sWindowText, _
        WS_CAPTION, iLeft, iTop, iWidth, iHeight, _
        hwnd_p, 0, hinst_p, 0&)

    iRet = GetClientRect16(hwnd16, rc)

    hwnd_Bar16 = CreateWindowEx16(0, "Static", "", _
        WS_CHILD Or SS_BLACKFRAME, 8, 16, rc.Right - 16, 24, _
        hwnd16, 0, hinst_p, 0&)

    iBarWidth = rc.Right - 18
    iBarHeight = 22

    iRet = ShowWindow16(hwnd_Bar16, SW_SHOWNOACTIVATE)
    iRet = ShowWindow16(hwnd16, SW_SHOW)
    iRet = UpdateWindow16(hwnd_Bar16)
    iRet = UpdateWindow16(hwnd)
    Form_Show16 = True
End Function

Private Function Form_Hide16() As Boolean
    Dim iRet As Long
    If hwnd16 <> 0 Then
        iRet = ShowWindow16(hwnd16, SW_HIDE)
        iRet = DestroyWindow16(hwnd16)
        hwnd16 = 0
        hwnd_Bar16 = 0
    End If
    Form_Hide16 = True
End Function

Private Function DrawBar16(ByVal iArg As Integer) As Boolean
    Dim hdc As Integer
    Dim rc As RECT16, rc_Left As RECT16, rc_Right As RECT16
    Dim sz As SIZE16
    Dim x As Integer, y As Integer
    Dim iRet As Integer
    Dim sText As String

    If hwnd16 = 0 Then Exit Function
    If iArg < 0 Or iArg > 100 Then Exit Function

    sText = CStr(iArg) & "%"

    With rc_Left
        .Left = 1
        .Top = 1
        .Right = (CLng(iBarWidth) * iArg) \ 100 + 1
        .Bottom = iBarHeight + 1
    End With

    With rc_Right
        .Left = rc_Left.Right
        .Top = 1
        .Right = iBarWidth + 1
        .Bottom = iBarHeight + 1
    End With

    hdc = GetDC16(hwnd_Bar16)

    iRet = GetTextExtentPoint16(hdc, sText, Len(sText), sz)
    x = (iBarWidth - sz.cx) \ 2 + 1
    y = (iBarHeight - sz.cy) \ 2 + 1

    iRet = SetBkColor16(hdc, &hff0000)
    iRet = SetTextColor16(hdc, &hffffff)
    iRet = ExtTextOut16(hdc, x, y, ETO_CLIPPED Or ETO_OPAQUE, _
            rc_Left, sText, Len(sText), 0&)

    iRet = SetTextColor16(hdc, &h0)
    iRet = SetBkColor16(hdc, &hffffff)
    iRet = ExtTextOut16(hdc, x, y, ETO_CLIPPED Or ETO_OPAQUE, _
        rc_Right, sText, Len(sText), 0&)

    iRet = ReleaseDC16(hwnd_Bar16, hdc)

    DrawBar16 = True
End Function


'サンプルマクロ

'以下のマクロは別モジュールに作成してください。

'エラートラップを行い、確実にウィンドウを破棄する
'ようにしてください。

Sub Test_DlgWait()
    Dim n As Long
    Dim i As Long

    'エラートラップを必ず行います
    On Error GoTo ErrorHandler
    Application.EnableCancelKey = xlErrorHandler

    '念のためウィンドウを破棄するマクロを自動実行させます
    Application.OnTime Now, "DLGW_Free"

    'ダイアログボックスのタイトルの設定
    sWindowText = "処理中です..."

    'ダイアログボックスの表示
    DLGW_Show

    'プログレスバーの初期表示
    DLGW_Value = 0

    n = 1000000
    For i = 1 To n

        '処理...

        'プログレスバーの更新
        DLGW_Value = Int(i / n * 100)

    Next

    'ウィンドウの破棄（必ず行います）
    DLGW_Free

    Exit Sub

ErrorHandler:

    'ウィンドウの破棄（必ず行います）
    DLGW_Free

    MsgBox "エラーが発生しました。", vbExclamation
End Sub