【VBA×WindowsAPI】UserFormに回転させたテキスト(文字列)を描画する

VBAでUserFormを作成していると文字を回転させて表示させたいという場面に出くわすことがあります。しかしラベルをはじめコントロールは回転させることが出来ないので、VBAの標準機能だけではこれを実現することはできません。

しかし、WindowsAPIの関数を利用することでこの問題を解決することはできます。
そこで本ページではUserFormに任意の角度だけ回転したテキストを描画する方法を解説していきます。描画されるテキストはUserFormのコントロールのような実態のあるものではないため、少し取り扱いは難しいですがテキスト描画だけでいえばかなりの自由度のある設定が可能です。

1. UserFormに回転させたテキストを描画する
2. サンプルコード
3. コード解説
4. 関連情報

UserFormに回転させたテキストを描画する

WindowsAPIを使うことで上画像のようにUserForm上に回転させたテキストを描画することができます。このとき描画するテキストは回転角度だけでなくフォントやサイズ、描画位置、フォント太さ、斜体、下線付き、取り消し線付きなどの細かな設定を行うことが可能です。

ただし、この方法で描画されるテキストはあくまでも視覚的に描画されているだけであり、ラベル等のコントロール(オブジェクト)として存在するわけではありません。テキストの値を変更するには既に描画されているテキストを消して再描画する必要があるので動的に扱う場合は注意が必要です。

WindowsAPIでテキストを描画するにはUserFormウィンドウが持つデバイスコンテキスト(DC)にアクセスする必要があります。DCとは主にウィンドウの描画関係の機能を取り扱うもので、GetDC関数やGetWindowDC関数に引数として対象のウィンドウハンドルを渡すことで取得することができます。また、描画するテキストの値やサイズ、角度などの情報を持つ「論理フォント」というGDIオブジェクトを作成して、描画対象のDCに関連付けさせる必要があります。

VBAでUserFormに回転させたテキストを描画するには下記のWindows APIを利用します。
それぞれ関数のより詳細な使い方の解説は各関数のリンクページを参照下さい。

FindWindow関数 ：ウィンドウハンドルを取得する
GetDC関数 ：デバイスコンテキスト(DC)を取得する
ReleaseDC関数 ：指定のDCを解放する
SelectObject関数 ：指定のDCでオブジェクト(論理フォント)を1つ選択する
DeleteObject関数 ：指定のオブジェクト(論理フォント)を1つ削除する
CreateFontIndirect関数 　：論理フォントを作成する
TextOut関数 ：指定の論理フォントでテキストを描画する
SetBkMode関数 ：テキストの背景を透明にする

「そもそもWindows APIって何？」という方はコチラ(メインページ)も併せて参照下さい。
また、その他のウィンドウへの描画関連の操作に関しては下記も併せて参照下さい。

・VBAで指定のウィンドウ(UserForm)に図形を描画する

サンプルコード

UserFormに回転させたテキストを描画するためのサンプルコードは下記の通りです。
下記コードをUserFormのコードにコピーペーストし、UseFormを表示させるだけで上画像の通り3つの回転したテキストを描画することができます。(※Topのみはラベルコントロールで作成したもの)

Option Explicit

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDc As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDc As LongPtr, ByVal nBkMode As Long) As Long

'論理ﾌｫﾝﾄ構造体
Private Const LF_FACESIZE = 32

Private Type LOGFONT
    lfHeight As Long                '文字の高さ
    lfWidth As Long                 '文字の平均幅
    lfEscapement As Long            '文字送りの方向とx軸との角度
    lfOrientation As Long           'ﾍﾞｰｽﾗｲﾝとx軸の角度
    lfWeight As Long                'ﾌｫﾝﾄ太さ (0～1000)
    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

'背景色透明化
Private Const TRANSPARENT = 1

Private hWnd        As LongPtr      'UserFormﾊﾝﾄﾞﾙ
Private hDc         As LongPtr      'UserFormﾃﾞﾊﾞｲｽｺﾝﾃｷｽﾄ

Private hFontDef    As LongPtr      'ﾃﾞﾌｫﾙﾄﾌｫﾝﾄ
Private cFonts      As Collection   '作成した論理ﾍﾟﾝｺﾚｸｼｮﾝ

'------------------------------------------------------------------
'   UserForm起動時ｲﾍﾞﾝﾄ
'------------------------------------------------------------------
Private Sub UserForm_Initialize()

    hWnd = FindWindow(vbNullString, Me.Caption)
    hDc = GetDC(hWnd)
    
    Set cFonts = New Collection
    
    'ﾃﾞﾌｫﾙﾄﾌｫﾝﾄの取得
    Call GetDefaultFont

End Sub
Private Sub GetDefaultFont()
    
    Dim lpLogFont As LOGFONT
    Dim hFontTmp As LongPtr
    
    hFontTmp = CreateFontIndirect(lpLogFont)
    hFontDef = SelectObject(hDc, hFontTmp)
 
    cFonts.Add hFontTmp
    
End Sub

'------------------------------------------------------------------
'   UserFormｱｸﾃｨﾌﾞｲﾍﾞﾝﾄ
'------------------------------------------------------------------
Private Sub UserForm_Activate()

    'ﾃｷｽﾄ描画はUserFormが表示された後に行う必要があるため
    'InitializeｲﾍﾞﾝﾄではなくActivateｲﾍﾞﾝﾄでRepaint後に行う必要あり
    
    Me.Repaint
    
    Dim hFontLeft   As LongPtr
    Dim hFontBottom As LongPtr
    Dim hFontRight  As LongPtr
    
    'ﾌｫﾝﾄ設定
    hFontLeft = CreateLogicalFont(13, 90)       '90deg回転
    hFontBottom = CreateLogicalFont(13, 180)    '180deg回転
    hFontRight = CreateLogicalFont(13, 270)     '270deg回転
    cFonts.Add hFontLeft
    cFonts.Add hFontRight
    cFonts.Add hFontBottom
    
    'ﾃｷｽﾄ描画
    Call DrawText("Left", hFontLeft, 23, 77)
    Call DrawText("Bottom", hFontBottom, 94, 122)
    Call DrawText("Right", hFontRight, 135, 55)

End Sub
'------------------------------------------------------------------
'   ﾃｷｽﾄ描画
'       sText   ：ﾃｷｽﾄ
'       lpFont  ：描画ﾌｫﾝﾄ
'       lX      ：x座標
'       lY      ：y座標
'------------------------------------------------------------------
Private Sub DrawText(ByVal sText As String, ByVal lpFont As LongPtr, _
                     ByVal lX As Long, ByVal lY As Long)
    
    'DCにﾌｫﾝﾄを設定
    Call SelectObject(hDc, lpFont)
    
    '背景色を透明に設定
    Call SetBkMode(hDc, TRANSPARENT)
    
    'ﾃｷｽﾄ出力
    Call TextOut(hDc, lX, lY, sText, Len(sText))

End Sub
'------------------------------------------------------------------
'   論理ﾌｫﾝﾄ作成
'       lHeight ：ﾃｷｽﾄ高さ
'       lAngle  ：ﾃｷｽﾄ角度(deg)
'------------------------------------------------------------------
Private Function CreateLogicalFont(ByVal lHeight As Long, ByVal lAngle As Long) As LongPtr
 
    Dim lpLogFont As LOGFONT
    Dim hFont As LongPtr
 
    'ﾌｫﾝﾄ設定
    With lpLogFont
        .lfHeight = lHeight         '高さ
        .lfEscapement = lAngle * 10 '回転角度
    End With
 
    '論理ﾌｫﾝﾄ作成
    hFont = CreateFontIndirect(lpLogFont)
    cFonts.Add hFont
    CreateLogicalFont = hFont
 
End Function

'------------------------------------------------------------------
'   UserForm終了時ｲﾍﾞﾝﾄ
'------------------------------------------------------------------
Private Sub UserForm_Terminate()

    Call DeleteAllObjects
    
    Set cFonts = Nothing
    Call ReleaseDC(hWnd, hDc)
    
End Sub
Sub DeleteAllObjects()
 
    Dim hFont 'As LongPtr
    
    '生成したﾌｫﾝﾄ削除
    Call SelectObject(hDc, hFontDef)
    For Each hFont In cFonts
        Call DeleteObject(hFont)
    Next
  
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

Option Explicit

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr

Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDc As LongPtr) As Long

Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDc As LongPtr, ByVal hObject As LongPtr) As LongPtr

Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long

Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr

Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long

Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDc As LongPtr, ByVal nBkMode As Long) As Long

'論理ﾌｫﾝﾄ構造体

Private Const LF_FACESIZE = 32

Private Type LOGFONT

lfHeight As Long '文字の高さ

lfWidth As Long '文字の平均幅

lfEscapement As Long '文字送りの方向とx軸との角度

lfOrientation As Long 'ﾍﾞｰｽﾗｲﾝとx軸の角度

lfWeight As Long 'ﾌｫﾝﾄ太さ (0～1000)

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

'背景色透明化

Private Const TRANSPARENT = 1

Private hWnd As LongPtr 'UserFormﾊﾝﾄﾞﾙ

Private hDc As LongPtr 'UserFormﾃﾞﾊﾞｲｽｺﾝﾃｷｽﾄ

Private hFontDef As LongPtr 'ﾃﾞﾌｫﾙﾄﾌｫﾝﾄ

Private cFonts As Collection '作成した論理ﾍﾟﾝｺﾚｸｼｮﾝ

'------------------------------------------------------------------

' UserForm起動時ｲﾍﾞﾝﾄ

'------------------------------------------------------------------

Private Sub UserForm_Initialize()

hWnd = FindWindow(vbNullString, Me.Caption)

hDc = GetDC(hWnd)

Set cFonts = New Collection

'ﾃﾞﾌｫﾙﾄﾌｫﾝﾄの取得

Call GetDefaultFont

End Sub

Private Sub GetDefaultFont()

Dim lpLogFont As LOGFONT

Dim hFontTmp As LongPtr

hFontTmp = CreateFontIndirect(lpLogFont)

hFontDef = SelectObject(hDc, hFontTmp)

cFonts.Add hFontTmp

End Sub

'------------------------------------------------------------------

' UserFormｱｸﾃｨﾌﾞｲﾍﾞﾝﾄ

'------------------------------------------------------------------

Private Sub UserForm_Activate()

'ﾃｷｽﾄ描画はUserFormが表示された後に行う必要があるため

'InitializeｲﾍﾞﾝﾄではなくActivateｲﾍﾞﾝﾄでRepaint後に行う必要あり

Me.Repaint

Dim hFontLeft As LongPtr

Dim hFontBottom As LongPtr

Dim hFontRight As LongPtr

'ﾌｫﾝﾄ設定

hFontLeft = CreateLogicalFont(13, 90) '90deg回転

hFontBottom = CreateLogicalFont(13, 180) '180deg回転

hFontRight = CreateLogicalFont(13, 270) '270deg回転

cFonts.Add hFontLeft

cFonts.Add hFontRight

cFonts.Add hFontBottom

'ﾃｷｽﾄ描画

Call DrawText("Left", hFontLeft, 23, 77)

Call DrawText("Bottom", hFontBottom, 94, 122)

Call DrawText("Right", hFontRight, 135, 55)

End Sub

'------------------------------------------------------------------

' ﾃｷｽﾄ描画

' sText ：ﾃｷｽﾄ

' lpFont ：描画ﾌｫﾝﾄ

' lX ：x座標

' lY ：y座標

'------------------------------------------------------------------

Private Sub DrawText(ByVal sText As String, ByVal lpFont As LongPtr, _

ByVal lX As Long, ByVal lY As Long)

'DCにﾌｫﾝﾄを設定

Call SelectObject(hDc, lpFont)

'背景色を透明に設定

Call SetBkMode(hDc, TRANSPARENT)

'ﾃｷｽﾄ出力

Call TextOut(hDc, lX, lY, sText, Len(sText))

End Sub

'------------------------------------------------------------------

' 論理ﾌｫﾝﾄ作成

' lHeight ：ﾃｷｽﾄ高さ

' lAngle ：ﾃｷｽﾄ角度(deg)

'------------------------------------------------------------------

Private Function CreateLogicalFont(ByVal lHeight As Long, ByVal lAngle As Long) As LongPtr

Dim lpLogFont As LOGFONT

Dim hFont As LongPtr

'ﾌｫﾝﾄ設定

With lpLogFont

.lfHeight = lHeight '高さ

.lfEscapement = lAngle * 10 '回転角度

End With

'論理ﾌｫﾝﾄ作成

hFont = CreateFontIndirect(lpLogFont)

cFonts.Add hFont

CreateLogicalFont = hFont

End Function

'------------------------------------------------------------------

' UserForm終了時ｲﾍﾞﾝﾄ

'------------------------------------------------------------------

Private Sub UserForm_Terminate()

Call DeleteAllObjects

Set cFonts = Nothing

Call ReleaseDC(hWnd, hDc)

End Sub

Sub DeleteAllObjects()

Dim hFont 'As LongPtr

'生成したﾌｫﾝﾄ削除

Call SelectObject(hDc, hFontDef)

For Each hFont In cFonts

Call DeleteObject(hFont)

End Sub

コード解説

図形を描画するには下記の手順を行います。

① 描画対象のウィンドウのDCへのハンドルを取得する (GetDC関数)
② フォントの作成 (CreateFontIndirect関数)
③ フォントを描画対象のウィンドウのDCに関連付ける (SelectObject関数)
④ テキストの描画 (TextOut関数, SetBkMode関数など)
⑤ 作成したフォントの削除 (DeleteObject関数)
⑥ DCの解放 (ReleaseDC関数)

描画対象のウィンドウのDCへのハンドルを取得する

ウィンドウには描画関係の処理を行うためのデバイスコンテキスト(DC)というものが存在します。
このDCを介すことで、ウィンドウ内のピクセル情報を取得したり、図形の描画を行ったりすることが可能になります。DCを取得するにはまず対象のウィンドウのンドルを取得する必要があります。これはウィンドウを識別するためのID情報のようなもので、ハンドルを取得すれば”どの”ウィンドウに対して処理を行うのかを簡単に指示することができます。(Windows APIでは頻出ワードです)

今回はUserFormに回転させたテキストを描画させたいので、UserFormウィンドウのハンドルを取得します。ウィンドウハンドルを取得する方法はいくつも存在しますがここでは常套手段のFindWindow関数を使ってウィンドウハンドルを取得しています。FindWindow関数は下記のように記載することで指定のクラス名もしくはウィンドウ名から該当のウィンドウへのハンドルを取得することができます。(UserFoemの場合はウィンドウ名に「Me.Caption」で取得可能)

FindWindow関数

hWnd = FindWindow(“クラス名”, “ウィンドウ名”)

UserFormのウィンドウハンドル取得後、それをそのままGetDC関数に引数として渡せばUserFormの”DCハンドル”を取得することができます。GetDC関数は下記のように記載します。

GetDC関数

hDC = GetDC(hWnd)

ここで取得したDCは最終的にメモリから明示的に解放させる必要があるので注意が必要です。
　

フォントの作成

WindowsAPIでテキストを描画するにはGDIオブジェクトである論理フォントというものを作成する必要があります。論理フォントを作成するにはCreateFontIndirect関数を使います。

CreateFontIndirect関数は下記のように描画するテキストのフォントに関する情報を格納したLOGFONT構造体を引数として入力することで任意の論理フォントを作成し、そのハンドルを取得することができます。論理フォントで設定できる内容は全部で14種ありますが、ここではテキストの大きさと回転の情報のみを設定します。その他についてはLOGFONTA 構造体(公式ページ)を参照下さい。

CreateFontIndirect関数

With lpLogFont
.lfHeight = lHeight ‘高さ
.lfEscapement = lAngle * 10 ‘回転角度
End With
hFont = CreateFontIndirect(lpLogFont)

テキストの回転角度は「lfEscapement」に値を格納しますが、実際の回転角度としてはここに格納された値の1/10の値となります。そのため、上記のように指定の角度から10倍した値を入力しておく必要があります。(※lfOrientationも角度情報ですが文字自体の回転ではありません)
　　

フォントを描画対象のウィンドウのDCに関連付ける

作成した論理フォントは描画対象のDCと関連付けることで、そのDC内でテキストを描画する際に作成した論理フォントでテキストを描画することが可能になります。これはSelectObject関数を使って下記のように記載することで設定ができます。SelectObject関数はこれまでに取得した描画対象ウィンドウのDCハンドル(hDc)と、描画するための論理フォント(hFont)を引数として渡すだけです。

SelectObject関数

hFont = SelectObject(hDc, hFont)

このとき、戻り値であるhFontは今回関連付けたフォント(hFont)の”前”に関連付けられていたフォントへのハンドルです。初回の実行ではDCにデフォルトで設定されていたフォントへのハンドルが返されます。サンプルコードでは一時的なフォントを作成し、このDCにデフォルトで設定されていたフォントへのハンドルを取得しています(フォントの削除時に使用します)。DCには常に1つのフォントしか関連付けさせることが出来ないため、フォントを変更したい場合は毎回SelectObject関数で関連付けさせているフォントを切り替える必要があります。
　

テキストの描画

上記までで描画するための設定は完了したので実際にテキストを描画していきます。
まずはSetBkMode関数を使い、下記のように記載してテキスト背景の透過設定を行います。

SetBkMode関数

Call SetBkMode(hDc, TRANSPARENT)

第1引数にはDCハンドル(hDc)、第2引数には背景の透過設定の定数値であるTRANSPARENTを入力します。「TRANSPARENT」は該当のヘッダーファイル内に定義されていますが、VBAでは関数の呼び出しを行っているだけなのでこれら定数は定義されていません。そのため「Const TRANSPARENT= 1」というかたちでコードの初めに定義しています。(引数として直接「1」を入力しても可)

背景色の設定が終えたら実際にUserFormにテキストを描画します。
テキストを描画するにはTextOut関数を使い下記のように記載します。

TextOut関数

Call TextOut(hDc, lX, lY, sText, Len(sText))

第1引数にはDCハンドル(hDc)、第2,3引数にはテキストを描画するX,Y座標、第4引数には描画するテキスト文字列(sText)、第5引数には文字列の長さをそれぞれ入力します。これにより、指定の座標に入力した文字列のテキストが描画されます。このときのフォントはDCに関連付けられている論理フォントとなります。フォントを切り替えたい場合は前述の通り、SelectObject関数を使って論理フォントの切り替えを行う必要があります。
　

フォントの削除

論理フォントは使わなくなった場合、削除してメモリを解放する必要があります。
削除するにはDeleteObject関数を使って下記のように記載します。引数に作成した論理フォントのハンドルを渡すだけです。サンプルコードでは作成した論理フォントのハンドルを一旦すべてコレクションに格納し、UserFormのTerminateイベントで一気に解放していますが、フォントを使わなくなった時点で解放しても問題ありません。

DeleteObject関数

Call DeleteObject(hFont)　 ‘※hPenはDCと関連付けられていないこと

注意としてこの関数で論理フォントを削除する際、削除するフォントはDCに関連付けられて”いない”必要があります。つまりは最新でDCに関連付けたフォントは、DCとの関連付けを終了させるまで削除をしてはいけないということです。DCに関連付けているフォントはSelectObject関数で切り替えることができるので、先に保持しておいたデフォルトのフォントをDCに関連付けさせることで作成したフォントをすべて削除することが可能になります。
　　