'  -- 標準モジュール
Option Explicit
Public Const DEFAULT_CHARSET = 1
Public Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" ( _
    ByVal H As Long, _
    ByVal W As Long, _
    ByVal E As Long, _
    ByVal O As Long, _
    ByVal W As Long, _
    ByVal I As Long, _
    ByVal u As Long, _
    ByVal S As Long, _
    ByVal C As Long, _
    ByVal OP As Long, _
    ByVal CP As Long, _
    ByVal Q As Long, _
    ByVal PAF As Long, _
    ByVal F As String _
) 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 TextOut Lib "gdi32" Alias "TextOutA" ( _
    ByVal hDC As Long, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByVal lpString As String, _
    ByVal nCount As Long _
) As Long


'  -- フォーム
Option Explicit

#Const PRN = 1

Private Sub Command1_Click()
    Dim hFont As Long
    Dim hFontOld As Long
    Dim hDC As Long
    Dim I As Long
    Dim X As Long
    Dim Y As Long
    Dim nTwipsPerPixelY As Long
    
    Dim FontHeight As Long
    Dim FontName As String
    
    FontHeight = 32
    FontName = Me.Font.Name

#If PRN = 1 Then
    hDC = Printer.hDC
    Printer.Print " "
    X = Printer.ScaleWidth / 2 / Printer.TwipsPerPixelX
    Y = Printer.ScaleHeight / 2 / Printer.TwipsPerPixelY
    nTwipsPerPixelY = Printer.TwipsPerPixelY
#Else
    hDC = Me.hDC
    X = Me.ScaleWidth / 2 / Screen.TwipsPerPixelX
    Y = Me.ScaleHeight / 2 / Screen.TwipsPerPixelY
    nTwipsPerPixelY = Screen.TwipsPerPixelY
#End If
    
    For I = 0 To 36
        hFont = CreateFont(-(FontHeight * 20 / nTwipsPerPixelY), _
            0, _
            I * 100, _
            I * 100, _
            0, _
            False, _
            False, _
            False, _
            DEFAULT_CHARSET, _
            False, _
            False, _
            False, _
            False, _
            "@" & FontName)
        
        hFontOld = SelectObject(hDC, hFont)
        
        Call TextOut(hDC, X, Y, "あいうえお", 10)
        Call SelectObject(hDC, hFontOld)
        
        Call DeleteObject(hFont)
    Next
    
#If PRN = 1 Then
    Call Printer.EndDoc
#End If
End Sub