タイトルバー文字列を中央に表示する

● タイトルバー文字列を中央に表示する ●

数ピクセルずれるけど、まあ、こんなもんでしょう。使用用途はほとんどなさそう。タイトルバーアイコンの横幅サイズを GetSystemMetrics(SM_CXSMICON) で取得してるけど、これが正しいかはちょっと自信なし。

Private Type Size
    cx As Long
    cy As Long
End Type

'文字サイズを得る
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long

'ウインドウのテキストを取得する
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

'システム情報を取得する
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Const SM_CXSMICON = 49
'Private Const SM_CYSMICON = 50

'---------------------------------------------------------------------------
' 関数名 ： GetTitleBarText
' 機  能 ： タイトルバー文字列を取得する
' 引  数 ： (in)hWnd … ウインドウのハンドル
' 返り値 ： タイトルバーの文字列
'---------------------------------------------------------------------------
Private Function GetTitleBarCaption(ByVal hWnd As Long) As String
    Dim WindowTextLen As Long
    Dim WindowTextBuff As String * 255

    'ウインドウのテキストを取得する
    WindowTextLen = GetWindowText(hWnd, WindowTextBuff, Len(WindowTextBuff))
    If WindowTextLen = 0 Then Exit Function

    'ヌル文字を取り除く
    GetTitleBarCaption = Left$(WindowTextBuff, InStr(WindowTextBuff, Chr$(0)) - 1)
End Function

'---------------------------------------------------------------------------
' 関数名 ： SetCaptionToCenter
' 機  能 ： タイトルバー文字列をセンター化する
' 引  数 ： (in)SrcForm … 対象フォーム
' 返り値 ： なし
'---------------------------------------------------------------------------
Public Sub SetCaptionToCenter(ByVal SrcForm As Form)
    Dim TitleBarCaption As String     'タイトルバー文字列
    Dim TitleBarCaptionWidth As Long  'タイトルバー文字列の長さを格納
    Dim OneSpaceWidth As Integer      'スペース１個分の文字列を格納
    Dim udtSize As Size               'サイズ取得構造体
    Dim DefScaleMode As Integer       'デフォルトのScaleMode
    Dim TitleBarCaptionLeft As Long   'タイトルバー文字列描画Ｘ位置
    Dim SpaceNum As Long              'スペースの数

    'タイトルバー文字列を取得する
    TitleBarCaption = Trim$(GetTitleBarCaption(SrcForm.hWnd))
    If TitleBarCaption = vbNullString Then Exit Sub

    'フォームのScaleModeを取得し、ピクセルに変更する
    DefScaleMode = SrcForm.ScaleMode
    SrcForm.ScaleMode = vbPixels

    'スペース１文字のサイズ(幅)を取得する
    Call GetTextExtentPoint32(SrcForm.hDC, Space$(1), 1, udtSize)
    OneSpaceWidth = udtSize.cx

    'タイトルバー文字列のサイズ(幅)を取得する
    Call GetTextExtentPoint32(SrcForm.hDC, TitleBarCaption, _
                      LenB(StrConv(TitleBarCaption, vbFromUnicode)), udtSize)
    TitleBarCaptionWidth = udtSize.cx

    'タイトルバー描画位置 & 必要なスペースの数を算出
    TitleBarCaptionLeft = (SrcForm.ScaleWidth - TitleBarCaptionWidth) / 2
    If TitleBarCaptionLeft < 0 Then GoTo FuncExitProc
    SpaceNum = TitleBarCaptionLeft / OneSpaceWidth
    If TitleBarCaptionLeft Mod OneSpaceWidth Then SpaceNum = SpaceNum + 1

    'フォームにアイコンが設定されている
    If SrcForm.Icon.Handle Then
        'フォームのアイコンサイズ分、スペース文字数を減算
        SpaceNum = SpaceNum - (GetSystemMetrics(SM_CXSMICON) / OneSpaceWidth)
        '↓これはなくてもいいかな？
        'If GetSystemMetrics(SM_CXSMICON) Mod OneSpaceWidth Then SpaceNum = SpaceNum + 1
    End If

FuncExitProc:
    '左側にスペースを埋める
    SrcForm.Caption = String$(SpaceNum, Space$(1)) & TitleBarCaption

    'フォームのScaleModeを元に戻す
    SrcForm.ScaleMode = DefScaleMode
End Sub

戻る