NonSoft

大きいフォントのMsgBoxのサンプル(VB6)


 サンプル(ソース/コード)
<このサンプルの概要>
MsgBox(メッセージボックス)のフォントサイズが他の画面に比べ小さすぎると困ったため大きい
フォントのMsgBoxのサンプルソースを作ってみました。

このサンプルは標準のメッセージボックスのフォント名とフォントサイズを変更するものです。
別フォームでメッセージボックスに似た物を作った訳ではありませんので、フォントサイズ以外
は標準のメッセージボックスとまったく同じはずです。

VB6のフォームにCommandButtonを5つ配列で追加してお試しください。
本サンプルのキーワードは以下の通りです。
(1)SetWindowsHookEx
(2)LOGFONT
(3)WM_GETFONT
(4)WM_SETFONT
(5)SetWindowText
(6)SetWindowPos
(7)GetSystemMetrics

このサンプルは簡易版ですが、「大きいフォントのMsgBox(VB6/VB.NET/C#.NET)」 として 公開中のDLLは指定したフォントサイズでMsgBoxのサイズを自動調整しますので、より 使い安いくなっています。フォントの属性(太字、斜体、取消線、下線)の変更も可能で、 メッセージボックスをオーナーフォームの中央に表示する事も出来ます。 是非「便利ツール」コーナーもお試しください。

★標準モジュール(Module1.bas)
Option Explicit
'**********************************************************************
' 機能名    : MsgBox(VB6)のフォント変更
'
' 機能説明  : MsgBoxのフォントをカスタマイズして表示する
'
' 備考      : MsgBoxのフォント名とフォントサイズを変更する
'**********************************************************************
Public Const FONT_NAME = "MS Pゴシック"
Public Const FONT_SIZE = 24

Public Const WH_CBT = 5
Public Const HCBT_ACTIVATE = 5
Public Const WM_SETFONT = &H30
Public Const WM_GETFONT = &H31
Public Const LF_FACESIZE = &H20
Public Const POINT_PER_INCH = 72
Public Const LOGPIXELSY = 90
Public Const HWND_TOP = 0
Public Const HWND_BOTTOM = 1
Public Const HWND_TOPMOST = (-1)
Public Const HWND_NOTOPMOST = (-2)
Public Const SWP_NOSIZE = &H1&
Public Const SWP_NOMOVE = &H2&
Public Const SWP_NOZORDER = &H4&
Public Const SWP_NOREDRAW = &H8&
Public Const SWP_NOACTIVATE = &H10&
Public Const SWP_FRAMECHANGED = &H20&
Public Const SWP_SHOWWINDOW = &H40&
Public Const SWP_HIDEWINDOW = &H80&
Public Const SWP_NOCOPYBITS = &H100&
Public Const SWP_NOOWNERZORDER = &H200&
Public Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Public Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Public Const SM_CYCAPTION = 4&
Public Const SM_CYSMCAPTION = 51&
Public Const SM_CXBORDER = 5&
Public Const SM_CYBORDER = 6&
Public Const SM_CXDLGFRAME = 7&
Public Const SM_CYDLGFRAME = 8&
Public Const SM_CXFRAME = 32&
Public Const SM_CYFRAME = 33&

Public Type LOGFONT
  lfHeight          As Long
  lfWidth           As Long
  lfEscapement      As Long
  lfOrientation     As Long
  lfWeight          As Long
  lfItalic          As Byte
  lfUnderline       As Byte
  lfStrikeOut       As Byte
  lfCharSet         As Byte
  lfOutPrecision    As Byte
  lfClipPrecision   As Byte
  lfQuality         As Byte
  lfPitchAndFamily As Byte
  lfFaceName(LF_FACESIZE) As Byte
End Type

Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal msg As Long, _
    ByRef wParam As Long, _
    ByRef lParam As Any) As Long
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" ( _
    ByVal hObject As Long, _
    ByVal nCount As Long, _
    lpObject As Any) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" ( _
    ByVal hdc As Long, _
    ByVal nIndex As Long) As Long
Public Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" ( _
    lpLogFont As LOGFONT) As Long
Public Declare Function SelectObject Lib "gdi32" ( _
    ByVal hdc As Long, _
    ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" ( _
    ByVal hObject As Long) As Long
Public Declare Function SetWindowsHookEx Lib "user32.dll" Alias "SetWindowsHookExA" ( _
    ByVal idHook As Long, _
    ByVal lpfn As Long, _
    ByVal hMod As Long, _
    ByVal dwThreadId As Long) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32.dll" ( _
    ByVal hHook As Long) As Long
Public 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 uFlags As Long) As Long
Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" ( _
    ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
    ByVal hWnd1 As Long, _
    ByVal hWnd2 As Long, _
    ByVal lpsz1 As String, _
    ByVal lpsz2 As String) As Long
Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" ( _
    ByVal hwnd As Long, _
    ByVal lpString As String) As Long
Public Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long

Public lngHookPrcHandle  As Long            'フックプロセスハンドル
Public lngMsgFontHandle  As Long            'メッセージフォントハンドル
Public lngBtnFontHandle  As Long            'ボタンフォントハンドル
Public strPromptBak      As String          '表示するメッセージ
Public lngButtonBak      As VbMsgBoxStyle   '表示するボタン情報

' @(f)
' 関数名    : MsgBoxPlus
'
' 返り値    : MsgBoxと同じ
'
' 引き数    : MsgBoxと同じ
'
' 機能説明  : MsgBoxのフォントをカスタマイズして表示する
'
' 備考      :
'
Public Function MsgBoxPlus(Prompt As String, _
                           Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
                           Optional Title As String = "", _
                           Optional HelpFile, _
                           Optional Context) As VbMsgBoxResult
    On Error Resume Next

    ' デフォルトタイトル設定
    If Title = "" Then Title = App.Title
    
    'フック定義
    lngHookPrcHandle = 0
    lngMsgFontHandle = 0
    lngBtnFontHandle = 0
    lngHookPrcHandle = SetWindowsHookEx( _
        WH_CBT, AddressOf HookProc, App.hInstance, App.ThreadID)

    'メッセージボックスを呼ぶ
    strPromptBak = Prompt
    lngButtonBak = Buttons
    MsgBoxPlus = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
End Function

' @(f)
' 関数名    : HookProc
'
' 返り値    : 省略
'
' 引き数    : 省略
'
' 機能説明  : MsgBoxアクティブ化時の処理
'
' 備考      :
'
Public Function HookProc _
       (ByVal nCode As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long
    On Error Resume Next

    'MsgBoxアクティブ化
    Static blnFlag As Boolean
    If nCode = HCBT_ACTIVATE Then
        If blnFlag Then
            Exit Function
        End If
        blnFlag = True

        'MsgBox設定
        Call setMsgBox(wParam)

        'フック終了
        Call UnhookWindowsHookEx(lngHookPrcHandle)
        blnFlag = False
    End If

    'フック中止
    HookProc = False
End Function

' @(f)
' 関数名    : setMsgBox
'
' 返り値    : 無し
'
' 引き数    : MsgBoxのハンドル
'
' 機能説明  : MsgBox設定
'
' 備考      :
'
Private Sub setMsgBox(lngParaWnd As Long)
    On Error Resume Next

    Dim i           As Long
    
    'ボタン数チェック
    Dim lngBtnNum   As Long
    lngBtnNum = 1
    If (lngButtonBak And vbOKOnly) = vbOKOnly Then
        lngBtnNum = 1
    End If
    If (lngButtonBak And vbOKCancel) = vbOKCancel Then
        lngBtnNum = 2
    End If
    If (lngButtonBak And vbYesNo) = vbYesNo Then
        lngBtnNum = 2
    End If
    If (lngButtonBak And vbRetryCancel) = vbRetryCancel Then
        lngBtnNum = 2
    End If
    If (lngButtonBak And vbAbortRetryIgnore) = vbAbortRetryIgnore Then
        lngBtnNum = 3
    End If
    If (lngButtonBak And vbYesNoCancel) = vbYesNoCancel Then
        lngBtnNum = 3
    End If
    If (lngButtonBak And vbMsgBoxHelpButton) = vbMsgBoxHelpButton Then
        lngBtnNum = lngBtnNum + 1
    End If
    
    'メッセージのフォントを設定する
    Dim lngMsgWnd   As Long
    lngMsgWnd = getMsgWnd(lngParaWnd)
    Call setLOGFONT(lngMsgWnd, lngMsgFontHandle)

    'ボタンのフォント変更
    Dim lngBtnWnd1  As Long
    Dim lngBtnWnd2  As Long
    Dim lngBtnWnd3  As Long
    Dim lngBtnWnd4  As Long
    If lngBtnNum >= 1 Then
        'ボタン1
        lngBtnWnd1 = FindWindowEx(lngParaWnd, 0&, "Button" & vbNullChar, vbNullString)
        Call setLOGFONT(lngBtnWnd1, lngBtnFontHandle)
    End If
    If lngBtnNum >= 2 Then
        'ボタン2
        lngBtnWnd2 = FindWindowEx(lngParaWnd, lngBtnWnd1, "Button" & vbNullChar, vbNullString)
        Call setLOGFONT(lngBtnWnd2, lngBtnFontHandle)
    End If
    If lngBtnNum >= 3 Then
        'ボタン3
        lngBtnWnd3 = FindWindowEx(lngParaWnd, lngBtnWnd2, "Button" & vbNullChar, vbNullString)
        Call setLOGFONT(lngBtnWnd3, lngBtnFontHandle)
    End If
    If lngBtnNum >= 4 Then
        'ボタン4
        lngBtnWnd4 = FindWindowEx(lngParaWnd, lngBtnWnd3, "Button" & vbNullChar, vbNullString)
        Call setLOGFONT(lngBtnWnd4, lngBtnFontHandle)
    End If
    
    'ボタンサイズ設定
    Dim lngBWidth   As Long
    Dim lngBHeight  As Long
    lngBWidth = 140
    lngBHeight = 40

    'アイコンサイズ設定
    Dim lngIWidth   As Long
    Dim lngIHeight  As Long
    Dim lngIconWnd  As Long
    lngIWidth = 0
    lngIHeight = 0
    lngIconWnd = getIconWnd(lngParaWnd)
    If lngIconWnd <> 0 Then
        lngIWidth = 35
        lngIHeight = 35
    End If

    'タイトルバーの高さ設定
    Dim titleH      As Long
    titleH = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME) + 1
    
    '画面サイズ設定
    Dim lngMWidth   As Long
    Dim lngMHeight  As Long
    Dim lngWWidth   As Long
    Dim lngWHeight  As Long
    lngMWidth = (Screen.Width * 0.7 / Screen.TwipsPerPixelX)
    lngMHeight = (Screen.Height * 0.3 / Screen.TwipsPerPixelY)
    lngWWidth = lngIWidth + 17 + lngMWidth + 10
    lngWHeight = titleH + lngMHeight + 20 + lngBHeight + 13
    
    ' メッセージボックスの表示位置
    Dim lngX        As Long
    Dim lngY        As Long
    lngX = ((Screen.Width \ Screen.TwipsPerPixelX) - lngWWidth) \ 2
    lngY = ((Screen.Height \ Screen.TwipsPerPixelY) - lngWHeight) \ 2

    'メッセージボックスのサイズ変更
    Call SetWindowPos(lngParaWnd, 0, lngX, lngY, lngWWidth, lngWHeight, _
        SWP_NOZORDER Or SWP_NOACTIVATE)

    'アイコン領域指定
    lngX = 17
    If lngIconWnd <> 0 Then
        lngX = 12
        Call SetWindowPos(lngIconWnd, 0, _
            lngX, 13, 0, 0, _
            SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_NOSIZE)
        lngX = lngIWidth + 17
    End If

    'メッセージ領域指定
    Call SetWindowPos(lngMsgWnd, 0, _
        lngX, 10, lngMWidth, lngMHeight, _
        SWP_NOZORDER Or SWP_NOACTIVATE)

    'メッセージの設定する
    Call SetWindowText(lngMsgWnd, strPromptBak)

    'ボタンの表示位置計算
    Dim lngBtnX1    As Long
    Dim lngBtnX2    As Long
    Dim lngBtnX3    As Long
    Dim lngBtnX4    As Long
    If lngBtnNum = 1 Then
        lngBtnX1 = ((lngWWidth \ 2) * 1) - (lngBWidth \ 2)
    End If
    If lngBtnNum = 2 Then
        lngBtnX1 = ((lngWWidth \ 3) * 1) - (lngBWidth \ 2)
        lngBtnX2 = ((lngWWidth \ 3) * 2) - (lngBWidth \ 2)
    End If
    If lngBtnNum = 3 Then
        lngBtnX1 = ((lngWWidth \ 4) * 1) - (lngBWidth \ 2)
        lngBtnX2 = ((lngWWidth \ 4) * 2) - (lngBWidth \ 2)
        lngBtnX3 = ((lngWWidth \ 4) * 3) - (lngBWidth \ 2)
    End If
    If lngBtnNum = 4 Then
        lngBtnX1 = ((lngWWidth \ 5) * 1) - (lngBWidth \ 2)
        lngBtnX2 = ((lngWWidth \ 5) * 2) - (lngBWidth \ 2)
        lngBtnX3 = ((lngWWidth \ 5) * 3) - (lngBWidth \ 2)
        lngBtnX4 = ((lngWWidth \ 5) * 4) - (lngBWidth \ 2)
    End If

    'ボタン表示
    If lngBtnNum >= 1 Then
        'ボタン1
        Call SetWindowPos(lngBtnWnd1, 0, _
            lngBtnX1, lngWHeight - titleH - lngBHeight - 13, _
            lngBWidth, lngBHeight, SWP_NOZORDER Or SWP_NOACTIVATE)
    End If
    If lngBtnNum >= 2 Then
        'ボタン2
        Call SetWindowPos(lngBtnWnd2, 0, _
            lngBtnX2, lngWHeight - titleH - lngBHeight - 13, _
            lngBWidth, lngBHeight, SWP_NOZORDER Or SWP_NOACTIVATE)
    End If
    If lngBtnNum >= 3 Then
        'ボタン3
        Call SetWindowPos(lngBtnWnd3, 0, _
            lngBtnX3, lngWHeight - titleH - lngBHeight - 13, _
            lngBWidth, lngBHeight, SWP_NOZORDER Or SWP_NOACTIVATE)
    End If
    If lngBtnNum >= 4 Then
        'ボタン4
        Call SetWindowPos(lngBtnWnd4, 0, _
            lngBtnX4, lngWHeight - titleH - lngBHeight - 13, _
            lngBWidth, lngBHeight, SWP_NOZORDER Or SWP_NOACTIVATE)
    End If
End Sub

' @(f)
' 関数名    : setLOGFONT
'
' 返り値    : 無し
'
' 引き数    : 省略
'
' 機能説明  : フォントの変更
'
' 備考      :
'
Private Sub setLOGFONT(ByVal lngParaWnd As Long, _
                    ByRef inParaHFont As Long)
    On Error Resume Next

    If inParaHFont = 0 Then
        'デバイスコンテキストを得る
        Dim lngHDC       As Long
        lngHDC = GetDC(lngParaWnd)

        '現在のフォントのハンドルを取得
        Dim lngHFont       As Long
        lngHFont = SendMessage(lngParaWnd, WM_GETFONT, 0, 0&) And &HFFFF&

        ' フォント属性を取得
        Dim typLOGFONT As LOGFONT
        Call GetObject(lngHFont, Len(typLOGFONT), typLOGFONT)

        '新しいフォント設定
        Dim i       As Long
        Dim fname() As Byte
        fname() = StrConv(FONT_NAME, vbFromUnicode)
        For i = 0 To UBound(fname)
          typLOGFONT.lfFaceName(i) = fname(i)
        Next i
        typLOGFONT.lfHeight = FONT_SIZE * _
            (GetDeviceCaps(GetDC(lngParaWnd), LOGPIXELSY) / _
            POINT_PER_INCH) * (typLOGFONT.lfHeight / _
            Abs(typLOGFONT.lfHeight))
        typLOGFONT.lfWeight = 400
        typLOGFONT.lfItalic = 0
        typLOGFONT.lfStrikeOut = 0
        typLOGFONT.lfUnderline = 0

        '論理フォントの作成
        inParaHFont = CreateFontIndirect(typLOGFONT)
        'DCへの関連付け
        Call SelectObject(lngHDC, inParaHFont)
    End If
    'フォントを指定
    Call SendMessage(ByVal lngParaWnd, ByVal WM_SETFONT, ByVal inParaHFont, 0&)
End Sub

' @(f)
' 関数名    : getIconWnd
'
' 返り値    : アイコン部分のハンドル
'
' 引き数    : MsgBoxのハンドル
'
' 機能説明  : アイコン部分のハンドル取得
'
' 備考      :
'
Private Function getIconWnd(lngParaWnd As Long) As Long
    On Error Resume Next

    Dim lngWnd1 As Long
    Dim lngBtnWnd2 As Long

    lngWnd1 = FindWindowEx(lngParaWnd, 0&, "Static" & vbNullChar, vbNullString)
    lngBtnWnd2 = FindWindowEx(lngParaWnd, lngWnd1, "Static" & vbNullChar, vbNullString)

    getIconWnd = IIf(lngBtnWnd2 <> 0&, lngWnd1, 0)
End Function

' @(f)
' 関数名    : getMsgWnd
'
' 返り値    : メッセージ部分のハンドル
'
' 引き数    : MsgBoxのハンドル
'
' 機能説明  : メッセージ部分のハンドル取得
'
' 備考      :
'
Private Function getMsgWnd(lngParaWnd As Long) As Long
    On Error Resume Next

    Dim lngWnd1 As Long
    Dim lngWnd2 As Long

    lngWnd1 = FindWindowEx(lngParaWnd, 0&, "Static" & vbNullChar, vbNullString)
    lngWnd2 = FindWindowEx(lngParaWnd, lngWnd1, "Static" & vbNullChar, vbNullString)

    getMsgWnd = IIf(lngWnd2 <> 0&, lngWnd2, lngWnd1)
End Function

' @(f)
' 関数名    : getBtnWnd
'
' 返り値    : ボタン部分のハンドル
'
' 引き数    : MsgBoxのハンドル
'
' 機能説明  : ボタン部分のハンドル取得
'
' 備考      :
'
Private Function getBtnWnd(lngParaWnd As Long) As Long
    On Error Resume Next

    getBtnWnd = FindWindowEx(lngParaWnd, 0&, "Button" & vbNullChar, vbNullString)
End Function

★フォームモジュール(Form1.frm)
Option Explicit

Private Sub Command1_Click(Index As Integer)
    Dim i As Long
    Dim c As String
    Dim msg As String
    Dim btn As VbMsgBoxStyle
    If Index = 0 Then
        btn = vbOKOnly
    ElseIf Index = 1 Then
        btn = vbOKOnly + vbQuestion
    ElseIf Index = 2 Then
        btn = vbOKCancel + vbInformation
    ElseIf Index = 3 Then
        btn = vbYesNoCancel + vbExclamation
    ElseIf Index = 4 Then
        btn = vbYesNoCancel + vbCritical + vbMsgBoxHelpButton
    End If

    ' メッセージボックス(MsgBox)表示
    msg = "1234567890" & vbCrLf & "12345678901234567890123456789012345678901234567890123456789012345
           67890123456789012345678901234567890123456789012345678901234567890123456789012345678901234
           5678901234567890123456789012345678901234567890"
    MsgBoxPlus msg, btn, msg

    ' メッセージボックス(MsgBox)表示
    msg = "1234567890" & vbCrLf & "123456789012345678901234567
           89012345678901234567890123456789012345678901
           23456789012345678901234567890"
    MsgBoxPlus msg, btn, msg

    ' メッセージボックス(MsgBox)表示
    msg = "ABCDEFGHIJKLMN" & vbCrLf & "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHI
           JKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRST
           UVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ"
    MsgBoxPlus msg, btn, msg

    ' メッセージボックス(MsgBox)表示
    msg = "ABCDEFGHIJ" & vbCrLf & "ABCDEFGHIJKLMNOPQRSTUVWXYZA
           BCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRS
           TUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ"
    MsgBoxPlus msg, btn, msg

    ' メッセージボックス(MsgBox)表示
    msg = "アイウエオカキクケコサシス" & vbCrLf & "アイウエオカキクケコサシスセソタチツテトナニヌネノハヒフヘホマミムメモヤイユエヨラリルレロワンアイウエオカキクケコサシスセソ
           タチツテトナニヌネノハヒフヘホマミムメモヤイユエヨラリルレロワンアイウエオカキクケコサシスセソタチツテトナニヌネノハヒフヘホマミムメモヤイユエヨラリルレロワンアイウエオカキクケコ
           サシスセソタチツテトナニヌネノハヒフヘホマミムメモヤイユエヨラリルレロワン"
    MsgBoxPlus msg, btn, msg

    ' メッセージボックス(MsgBox)表示
    msg = "アイウエオカキクケコ" & vbCrLf & "アイウエオカキクケコサシスセソタチツテトナニヌネノハヒ
           フヘホマミムメモヤイユエヨワンアイウエオカキクケコサシスセソタチツテトナニヌネノハヒフヘ
           ホマミムメモヤイユエヨワン"
    MsgBoxPlus msg, btn, msg

    ' メッセージボックス(MsgBox)表示
    msg = "あいうえおかきくけこ" & vbCrLf & "あいうえおかきくけこさしすせそたちつてとなにぬねのはひ
           ふへほまみむめもやいゆえよわんあいうえおかきくけこさしすせそたちつてとなにぬねのはひふへ
           ほまみむめもやいゆえよわん"
    MsgBoxPlus msg, btn, msg

    ' メッセージボックス(MsgBox)表示
    msg = ""
    c = "亜"
    For i = 0 To 99
        msg = msg & Chr(Asc(c) + i)
        If i = 9 Then
        msg = msg & vbCrLf
        End If
    Next i
    MsgBoxPlus msg, btn, msg
End Sub