CreateFont

指定の属性を持つ論理フォントを作成する

Declare Function CreateFont lib "gdi32.dll" Alias "CreateFontA" _

        (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, _

        ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Long, _

        ByVal fwUnderline As Long, ByVal fdwStrinkeOut As Long, ByVal CharSet As Long, _

        ByVal OutputPrecision As Long, ByVal ClipPrecision As Long, ByVal Quality As Long, _

        ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long

フォントの高さ

同、平均幅(通常0)

相対的出力角度(単位：1/10度)

回転角度(単位：1/10度)

文字の線幅

イタリック体のとき

アンダーライン付きのとき１

横線付きのとき１

文字セットの指定

常にOUT_DEFAULT_PRECIS(=0)

同上

xxx_QUALITY

PitchAndFamily xxx_PITCH

タイプフェース名

正常終了のとき                            論理フォントのハンドル

エラーのとき                              0

この関数はCreateFontIndirect()関数と同じである。

取得したハンドルは使用後、DeleteObject()関数を使って解放する。

FW_DONTCARE = 0                    デフォルト

FW_THIN = 100                      (以下、数値が大きくなるほど太字になる)

FW_EXTRALIGHT = 200

FW_ULTRALIGHT = FW_EXTRALIGHT

FW_LIGHT = 300

FW_NORMAL = 400

FW_REGULAR = FW_NORMAL

FW_MEDIUM = 500

FW_SEMIBOLD = 600

FW_DEMIBOLD = FW_SEMIBOLD

FW_BOLD = 700

FW_EXTRABOLD = 800

FW_ULTRABOLD = FW_EXTRABOLD

FW_HEAVY = 900

FW_BLACK = FW_HEAVY

ANSI_CHARSET = 0                   Windowsの標準文字セット

DEFAULT_CHARSET = 1                デフォルトの文字セット

OEM_CHARSET = 255                  OEM文字セット(システムに依存する)

SHIFTJIS_CHARSET = 128             シフトJIS文字セット

SYMBOL_CHARSET = 2                 シンボル文字セット

BALTIC_CHARSET = 186

CHINESEBIG5_CHARSET = 136

EASTEUROPE_CHARSET = 238

GREEK_CHARSET = 161

HANGEUL_CHARSET = 129

MAC_CHARSET = 77

RUSSIAN_CHARSET = 204

TURKISH_CHARSET = 162

DEFAULT_QUALITY = 0                デフォルト(特に指定しない)

DRAFT_QUALITY = 1                  PROOF_QUALITYほど品質を重視しない

PROOF_QUALITY = 2                  論理フォントの属性に一致させることにより
                                    フォントの品質を重視する

DEFAULT_PITCH = 0                  デフォルトのピッチ

FIXED_PITCH = 1                    固定ピッチ

VARIABLE_PITCH = 2                 可変ピッチ

FF_DECORATIVE = 80                 飾りフォント

FF_DONTCARE = 0                    フォントファミリに分類する必要がないフォント

FF_MODERN = 48                     固定幅ストローク、固定ピッチ、セリフあり・なし

FF_ROMAN = 16                      可変幅ストローク、可変ピッチ、セリフあり・なし

FF_SCRIPT = 64                     手書き風フォント

FF_SWISS = 32                      可変幅ストローク、可変ピッチ、セリフなし

ダウンロード(CreateFont.lzh)

Public Const IDM_BUTTON1 = &H100

Public Sub Main()
Dim wcl As WNDCLASSEX, msg As Message
Dim rc As Long
Dim hDlg As Long

'メインウィンドウの登録
With wcl
    .cbSize = Len(wcl)
    .lpszClassName = "test Class Name"
    .lpfnWndProc = ChangeAddressOf(AddressOf WndProc)
    .style = 0
    .cbClsExtra = 0
    .cbWndExtra = 0
    .lpszMenuName = 0
    .hbrBackground = GetStockObject(WHITE_BRUSH)
    .hInstance = App.hInstance
    '.hIcon = LoadIcon(App.hInstance, ByVal 32512)
    .hIcon = LoadIcon(0, ByVal 32512)
    .hCursor = LoadCursor(0, ByVal 32512)
End With
Call RegisterClassEx(wcl)

'メインウィンドウの作成
hDlg = CreateWindowEx(WS_EX_CLIENTEDGE, wcl.lpszClassName, "CreateFont()関数の実験", _
    WS_CAPTION Or WS_VISIBLE Or WS_SYSMENU, _
    CW_USEDEFAULT, CW_USEDEFAULT, 500, 300, 0, 0, App.hInstance, 0)

'コマンドボタンの作成
Call CreateWindowEx(0, "Button", "押す", WS_CHILD Or BS_PUSHLIKE Or WS_VISIBLE, _
    400, 20, 50, 30, hDlg, IDM_BUTTON1, App.hInstance, 0)
    
'メインウィンドウの表示
Call ShowWindow(hDlg, SW_SHOW)

'メッセージループ
Do While (GetMessage(msg, 0, 0, 0))
    Call TranslateMessage(msg)
    Call DispatchMessage(msg)
Loop

End Sub


Public Function WndProc(ByVal hWnd As Long, ByVal msg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
Dim hdc As Long, n As Long
Dim temp As String, rc1 As Long, rc2 As Long, temp1 As String
Dim lpFontName(5) As String

Select Case msg
    Case WM_COMMAND
        Select Case LWORD(wParam)
            Case IDM_BUTTON1
                'デバイスコンテキストの取得
                hdc = GetDC(hWnd)
                
                Call SetTextColor(hdc, QBColor(0))
                temp = "CreateFont()関数の実験"
                rc2 = LenB(StrConv(temp, vbFromUnicode))
                Call TextOut(hdc, 10, 10, temp, rc2)  '文字列
                
                temp = "日本語表示もできちゃう♪"
                rc2 = LenB(StrConv(temp, vbFromUnicode))
                
                lpFontName(1) = "system"
                lpFontName(2) = "ＭＳ明朝"
                lpFontName(3) = "ＭＳゴシック"
                lpFontName(4) = "ＭＳ Ｐ明朝"
                lpFontName(5) = "ＭＳ Ｐゴシック"
                
                y = 40
                For a = 1 To 5
                    'フォントの色を設定
                    Call SetTextColor(hdc, QBColor(a))
                    
                    temp1 = lpFontName(a)
                    rc1 = LenB(StrConv(temp1, vbFromUnicode))
                    Call SetFont(hWnd, hdc, 10, temp1)
                    Call TextOut(hdc, 10, y, temp1, rc1)   'フォント名
                    Call TextOut(hdc, 20, y + 20, temp, rc2)  '文字列
                    y = y + 40
                Next

                Call ReleaseDC(hWnd, hdc)
        End Select
    Case WM_CLOSE
        Call DestroyWindow(hWnd)
        Call PostQuitMessage(0)
    Case Else
        WndProc = DefWindowProc(hWnd, msg, wParam, lParam)
End Select
End Function

Public Function ChangeAddressOf(ByVal Address As Long) As Long
ChangeAddressOf = Address
End Function

Public Function HWORD(ByVal LongValue As Long) As Integer
'長整数値から上位ワードを取得する
HWORD = (LongValue And &HFFFF0000) \ &H10000
End Function

Public Function LWORD(ByVal LongValue As Long) As Integer
'長整数値から下位ワードを取得する
If (LongValue And &HFFFF&) > &H7FFF Then
    LWORD = (LongValue And &HFFFF&) - &H10000
Else
    LWORD = LongValue And &HFFFF&
End If
End Function

Public Function GetLong(ByVal UpperWord As Integer, ByVal LowerWord As Integer) As Long
'下位・上位を与えて長整数値(32ビット値)を取得する
    GetLong = (LowerWord And &HFFFF&) Or (UpperWord * &H10000)
End Function


Public Sub SetFont(ByVal hWnd As Long, ByVal hdc As Long, ByVal nPoint As Long, ByVal lpFontName As String)
'hWnd:ターゲットのウィンドウのハンドル
'hdc:タゲットのデバイスコンテキストのハンドル
'nPoint:フォントの大きさ
'lpFontName:フォント名

Dim hFont As Long

    Call SetMapMode(hdc, MM_TEXT)
    hFont = CreateFont(-nPoint * 2, 0, 0, 0, _
            FW_NOMAL, 0, 0, 0, DEFAULT_CHARSET, 0, 0, _
            DEFAULT_QUALITY, DEFAULT_PITCH Or FF_SCRIPT, lpFontName)
    Call SelectObject(hdc, hFont)
    Call SendMessage(hWnd, WM_SETFONT, hFont, 1)
End Sub