デバイスコンテキストに文字列を描画する

● デバイスコンテキストに文字列を描画する ●

デバイスコンテキストに文字列を表示する方法を簡単にまとめてみた。パッと思いつくAPI関数は TextOut と DrawText であるが、これはもうお約束の範疇かな。TextOut は表示位置を絶対座標で指定することが可能で、DrawText は表示位置を左上や右下など相対的に指定することが可能。今回は後者を使用している。

にしても、VBではどのような場面でこれらの関数を使うのかな？その昔、オーナードローメニューでメニュー文言を表示するときに使ったねぇ。他には、ロゴ作成ツール自作したときにプレビュー表示で使ったかもしれない。それ以外は…思いつかないや。

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

'矩形を取得する
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long

'テキストを描画する
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, ByRef lpRect As RECT, ByVal wFormat As Long) As Long

Private Const DT_PLOTTER = 0
Private Const DT_RASDISPLAY = 1
Private Const DT_RASPRINTER = 2
Private Const DT_RASCAMERA = 3
Private Const DT_CHARSTREAM = 4
Private Const DT_METAFILE = 5
Private Const DT_DISPFILE = 6
Private Const DT_TOP = &H0         '上揃え(単一行の時のみ)
Private Const DT_CENTER = &H1      '水平方向に中央揃え
Private Const DT_RIGHT = &H2       '右揃え
Private Const DT_VCENTER = &H4     '垂直方向に中央揃え(単一行の時のみ)
Private Const DT_BOTTOM = &H8      '下揃え(単一行の時のみ)
Private Const DT_WORDBREAK = &H10  '複数行表示
Private Const DT_SINGLELINE = &H20 '単一行表示
Private Const DT_EXPANDTABS = &H40 'タブ文字を展開
Private Const DT_TABSTOP = &H80    'タブ間隔設定
Private Const DT_NOCLIP = &H100    'クリッピングをしない
Private Const DT_EXTERNALLEADING = &H200  '行の高さにテキストの行間の高さを加算
Private Const DT_CALCRECT = &H400
Private Const DT_NOPREFIX = &H800
Private Const DT_INTERNAL = &H1000

Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long

Public Enum DRAW_POS
    TopLeft = 1       '上＆左
    TopCenter = 2     '上＆中央
    TopRight = 3      '上＆右
    MiddleLeft = 4    '中央＆左
    MiddleCenter = 5  '中央＆中央
    MiddleRight = 6   '中央＆右
    BottomLeft = 7    '下＆左
    BottomCenter = 8  '下＆中央
    BottomRight = 9   '下＆右
End Enum

'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
' 機  能：１行文字列を描画する
' 引  数：(i)ObjHavingDC … デバイスコンテキストを持つオブジェクト
'         (i)TargetText  … 表示する文字列
'         (i)RGBColor    … 文字色
'         (i)DrawPos     … 描画位置
' 返り値：描画したテキストの高さ  エラー時は0
' 備  考：デバイスコンテキストを強制的に AutoRedraw = True、ScaleMode = vbPixels とする
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Public Function DrawTextToDC(ByRef ObjHavingDC As Object, ByVal TargetText As String, _
                             Optional ByVal RGBColor As DRAW_POS = vbBlack, _
                             Optional ByVal DrawPos As DRAW_POS = TopLeft)
    Dim udtRect As RECT
    Dim TargetFormat As Long

    'デバイスコンテキストの矩形を取得する
    Call GetClientRect(ObjHavingDC.hwnd, udtRect)

    Select Case DrawPos
        Case TopLeft
            TargetFormat = DT_TOP
        Case TopCenter
            TargetFormat = DT_TOP Or DT_CENTER
        Case TopRight
            TargetFormat = DT_TOP Or DT_RIGHT
        Case MiddleLeft
            TargetFormat = DT_VCENTER
        Case MiddleCenter
            TargetFormat = DT_VCENTER Or DT_CENTER
        Case MiddleRight
            TargetFormat = DT_VCENTER Or DT_RIGHT
        Case BottomLeft
            TargetFormat = DT_BOTTOM
        Case BottomCenter
            TargetFormat = DT_BOTTOM Or DT_CENTER
        Case BottomRight
            TargetFormat = DT_BOTTOM Or DT_RIGHT
    End Select

    With ObjHavingDC
        .ScaleMode = vbPixels
        .AutoRedraw = True
        .ForeColor = RGBColor

        '文字列を描画する
        DrawTextToDC = DrawText(.hdc, TargetText, lstrlen(TargetText), udtRect, _
                                TargetFormat Or DT_SINGLELINE)

        '再描画
        .Refresh
    End With
End Function

で、フォームにピクチャーボックス(名前：picScreen)を配置して、フォームのロードイベントに以下を書く。

Private Sub Form_Load()
    Call DrawTextToDC(picScreen, "あいうえお", vbRed, TopLeft)
    Call DrawTextToDC(picScreen, "かきくけこ", QBColor(5), TopCenter)
    Call DrawTextToDC(picScreen, "さしすせそ", vbCyan, TopRight)
    Call DrawTextToDC(picScreen, "たちつてと", vbMagenta, MiddleLeft)
    Call DrawTextToDC(picScreen, "なにぬねの", vbBlack, MiddleCenter)
    Call DrawTextToDC(picScreen, "はひふへほ", vbWhite, MiddleRight)
    Call DrawTextToDC(picScreen, "まみむめも", vbYellow, BottomLeft)
    Call DrawTextToDC(picScreen, "やゐゆゑよ", vbGreen, BottomCenter)
    Call DrawTextToDC(picScreen, "わをん", vbBlue, BottomRight)
End Sub

戻る