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