縦書き文字印刷



FontをセットしてからPrinterオブジェクトに対して、
プロパティの参照やメソッドの実行すると思うように出力されないようです。
(Printer.ScaleWidthやPrinter.Print等)
Printerオブジェクトの挙動不審は昔からなくならないですね。

更新履歴
2001/08/16 バグ修正


'  -- 標準モジュール
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