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

'MakeDialogSheetマクロを実行してダイアログシートを作成し、
'Testマクロを実行してください。

Option Explicit

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 Const DialogSheetName = "Dialog1"

Private Const GWL_STYLE As Long = &hfff0
Private Const WS_SYSMENU As Long = &h80000 Or &h20000 Or &h10000
Private Const GW_CHILD = 5
Private Const ETO_CLIPPED = 4
Private Const ETO_OPAQUE = 2

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

Private Declare Function GetSystemMetrics Lib "user32" ( _
    ByVal nIndex As Long) As Long
Private Declare Function GetWindow Lib "user32" ( _
    ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" ( _
    ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" ( _
    ByVal hwnd As Long, lpRect As RECT) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function UpdateWindow 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 GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
    ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
    ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
    ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, _
    ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) 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 GetDeviceCaps Lib "gdi32" ( _
    ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SelectObject Lib "gdi32" ( _
    ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
    ByVal hObject As Long) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" ( _
    ByRef lpRect As RECT) 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 hwnd_Bar As Long
Private iBarWidth As Integer
Private iBarHeight As Integer
Private rc_Bar As RECT
Private rc_Left As RECT
Private rc_Right As RECT
Private iVersion As Long

Sub Form1_Show()
    Dim sClassName As String
    Dim iWindowStyle As Long
    Dim hwnd As Long
    Dim hwnd2 As Long
    Dim px As Double, py As Double
    Dim cx As Long, cy As Long
    Dim rc As RECT
    Dim iCount As Long
    Dim iRet As Long
    Dim i As Long

    Application.Cursor = xlNormal

    'ダイアログボックスのウィンドウハンドルの取得
    sClassName = "bosa_sdm_XL"
    hwnd = FindWindow(sClassName, ActiveDialog.DialogFrame.Caption)
    If hwnd = 0 Then
        sClassName = "bosa_sdm_XL8"
        hwnd = FindWindow(sClassName, ActiveDialog.DialogFrame.Caption)
        If hwnd = 0 Then
            ActiveDialog.Hide True
            Exit Sub
        Else
            iVersion = 8
        End If
    Else
        iVersion = 7
    End If

    'プログレスバー範囲の取得
    hwnd_Bar = GetWindow(hwnd, GW_CHILD)
    iRet = GetClientRect(hwnd_Bar, rc_Bar)
    If iVersion = 7 Then
        iBarWidth = rc_Bar.Right - 2
        iBarHeight = rc_Bar.Bottom - 2
        rc_Left.Left = 1
        rc_Left.Top = 1
        rc_Left.Bottom = rc_Bar.Bottom - 1
        rc_Right.Right = rc_Bar.Right - 1
        rc_Right.Top = 1
        rc_Right.Bottom = rc_Bar.Bottom - 1
    Else
        iBarWidth = rc_Bar.Right
        iBarHeight = rc_Bar.Bottom
        rc_Left.Left = 0
        rc_Left.Top = 0
        rc_Left.Bottom = rc_Bar.Bottom
        rc_Right.Right = rc_Bar.Right
        rc_Right.Top = 0
        rc_Right.Bottom = rc_Bar.Bottom
    End If

    'ウィンドウスタイルの設定
    iWindowStyle = GetWindowLong(hwnd, GWL_STYLE)
    SetWindowLong hwnd, GWL_STYLE, (iWindowStyle And (Not WS_SYSMENU))

    'ウィンドウ位置の設定
    cx = GetSystemMetrics(SM_CXSCREEN)
    cy = GetSystemMetrics(SM_CYSCREEN)
    iRet = GetWindowRect(hwnd, rc)
    SetWindowPos hwnd, 0, (cx - (rc.Right - rc.Left)) \ 2, _
        (cy - (rc.Bottom - rc.Top)) \ 2, 0, 0, 21

    'ダイアログボックスの表示
    iRet = ShowWindow(hwnd, 5)
    iRet = UpdateWindow(hwnd)

    iCount = 0
    DrawBar iCount
    Do

        '仮の処理
        For i = 1 To 90000
        Next

        '表示の更新
        iCount = iCount + 1
        DrawBar iCount

    Loop While iCount <= 100

    ActiveDialog.Hide
End Sub

Private Function DrawBar(ByVal iArg As Integer) As Boolean
    Dim hdc As Long
    Dim sz As SIZE
    Dim x As Long, y As Long
    Dim iRet As Long
    Dim sText As String
    Dim hrgn As Long
    Dim hrgn_Old As Long
    Dim iEnableCancelKey As Long

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

    iEnableCancelKey = Application.EnableCancelKey
    Application.EnableCancelKey = xlDisabled

    On Error Resume Next

    sText = CStr(iArg) & "%"
    rc_Left.Right = rc_Left.Left + (CLng(iBarWidth) * iArg) \ 100
    rc_Right.Left = rc_Left.Right

    hdc = GetDC(hwnd_Bar)
    hrgn = CreateRectRgnIndirect(rc_Bar)
    hrgn_Old = SelectObject(hdc, hrgn)

    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 = SelectObject(hdc, hrgn_Old)
    iRet = DeleteObject(hrgn)
    iRet = ReleaseDC(hwnd_Bar, hdc)

    Application.EnableCancelKey = iEnableCancelKey

    DrawBar = True
End Function

Function PointPerPixcelX(hwnd As Long) As Double
    Dim hdc As Long, rtn As Long, x As Long
    hdc = GetDC(hwnd)
    x = GetDeviceCaps(hdc, LOGPIXELSY)
    rtn = ReleaseDC(hwnd, hdc)
    PointPerPixcelX = 72 / x
End Function

Function PointPerPixcelY(hwnd As Long) As Double
    Dim hdc As Long, rtn As Long, y As Long
    hdc = GetDC(hwnd)
    y = GetDeviceCaps(hdc, LOGPIXELSY)
    rtn = ReleaseDC(hwnd, hdc)
    PointPerPixcelY = 72 / y
End Function

Sub Test()
    Dim bRet As Boolean
    bRet = ThisWorkbook.DialogSheets(DialogSheetName).Show()
    If bRet Then
        MsgBox "処理が完了しました。", vbInformation
    Else
        MsgBox "エラーが発生しました。", vbExclamation
    End If
End Sub

Sub MakeDialogSheet()
    Dim dlg As DialogSheet
    Dim gw As Double
    Application.ScreenUpdating = False
    Set dlg = DialogSheets.Add
    With dlg
        .Name = DialogSheetName
        gw = .Buttons(1).Height / 3
        With .DialogFrame
            .Left = gw * 7
            .Top = gw * 4
            .Width = gw * 44
            .Height = gw * 14
            .Caption = "実行中です..."
            .OnAction = "Form1_Show"
        End With
        .DrawingObjects.Delete
    End With
    With dlg.Labels.Add(Left:=gw * 9, Top:=gw * 7, _
            Width:=gw * 30, Height:=gw * 4)
        .Left = gw * 9
        .Top = gw * 7
        .Width = gw * 30
        .Height = gw * 4
        .Caption = "しばらくお待ちください..."
    End With
    With dlg.EditBoxes.Add(Left:=gw * 9, Top:=gw * 12, _
            Width:=gw * 40, Height:=gw * 3)
        .Left = gw * 9
        .Top = gw * 12
        .Enabled = False
    End With
End Sub