VBで横倍角/縦倍角を表示したいのですが

Question

ＶＢでラベルプリンターのイメージ表示みたいなものを作っていますが、
ラベルやテキストボックスに横倍角や縦倍角の文字を表示することは可能でしょうか。

taisuke555 · Accepted Answer

先に回答されている方と同じ理由でやはりピクチャーボックスでの方法です。

'*******************************************************
Option Explicit

Dim OB As Object  '表示オブジェクト
Dim FN As String  'フォント名
Dim FX As Integer 'フォントの横サイズ
Dim FY As Integer 'フォントの縦サイズ
Dim cx As Long    '表示X座標
Dim cy As Long    '表示Y座標

Private Const DEFAULT_CHARSET = 1
Private Const OUT_DEFAULT_PRECIS = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const FF_DONTCARE = 0
Private Const LF_FACESIZE = 32

Private Type Size
        cx As Long
        cy As Long
End Type
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    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 Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private 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
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long

Private Sub Command1_Click()
    Dim fnt                 As String
    Dim FntSizeX            As Integer
    Dim FntSizeY            As Integer
    
    fnt = "ＭＳ 明朝"
    FntSizeX = 12
    FntSizeY = 12
        
    With Picture1
        .FontName = fnt
        .FontSize = FntSizeX
        Picture1.Print "testてすと"
    End With
    
    Set OB = Picture1
    'Set OB = Printer
    'OB.Print ""     'Printerの場合初めにダミーを印刷しないと印刷されない
    FN = fnt
    
    FX = 12: FY = 12: cx = 0: cy = 500: PrintText "testてすと"
    FX = 12: FY = 24: cx = 0: cy = 1000: PrintText "testてすと" '縦倍角
    FX = 24: FY = 12: cx = 0: cy = 1500: PrintText "testてすと" '横倍角
End Sub

Sub PrintText(text As String)
    Dim LF                  As LOGFONT
    Dim IX                  As Integer
    
    Dim TempByteArray()     As Byte
    Dim ByteArrayLimit      As Long
    
    Dim OldFT               As Long
    Dim NewFT               As Long
    Dim rtn                 As Long
    Dim hdc                 As Long
    Dim sz                  As Size
    
    Dim TppX                As Long
    Dim TppY                As Long
    
    Dim PX                  As Long
    Dim PY                  As Long
    
    hdc = OB.hdc
    
    If (OB Is Printer) Then
        TppX = Printer.TwipsPerPixelY
        TppY = Printer.TwipsPerPixelX
    Else
        TppX = Screen.TwipsPerPixelY
        TppY = Screen.TwipsPerPixelX
    End If
    
    PX = cx / TppX
    PY = cy / TppY
    With LF
        .lfEscapement = 0           '文字の回転角度(角度*10)
        
        .lfHeight = FY * 20 / TppX  '文字の高さ
        .lfWidth = FX * 10 / TppY   '文字の幅
        
        .lfWeight = 400        '文字の太さ
        .lfItalic = False      '斜体
        .lfUnderline = False   '下線
        .lfStrikeOut = False   '取り消し線
        
        .lfCharSet = DEFAULT_CHARSET
        .lfOutPrecision = OUT_DEFAULT_PRECIS
        .lfClipPrecision = OUT_DEFAULT_PRECIS
        .lfQuality = DEFAULT_QUALITY
        .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
        
        TempByteArray = StrConv(FN, vbFromUnicode)
        ByteArrayLimit = UBound(TempByteArray)
        For IX = 0 To ByteArrayLimit
            .lfFaceName(IX) = TempByteArray(IX)
        Next
    End With

    NewFT = CreateFontIndirect(LF)
    OldFT = SelectObject(hdc, NewFT)
    
    'うまく表示されない場合、下記のコメントをはずす
    'GetTextExtentPoint32 hdc, text, LenB(StrConv(text, vbFromUnicode)), sz
    TextOut hdc, PX, PY, text, LenB(StrConv(text, vbFromUnicode))
    
    rtn = SelectObject(hdc, OldFT)
    rtn = DeleteObject(NewFT)
End Sub
'*******************************************************

フォームにpicturebox と commandbuttonを貼り付けて上記コードを貼り付けて実行してみてください

CreateFontIndirect APIを使用しています。
説明は省きますが、検索すればたくさんあると思います。
No.2の方と同じ様なもので回転も出来ます。
set OB = picture1 を　set OB = printer にすればPrinterにも同じ様に印刷されるので、
イメージ表示の感じになるのではないでしょうか？
今回は倍角についての質問でしたので、斜体、下線、太字等の設定は固定にしてあります。

TAGOSAKU7 · Answer

>ラベルやテキストボックスに横倍角や縦倍角の文字を表示することは可能でしょうか。

概念から説明しましょう。
VBのラベルは、WINDOWSは絵として認識しています。
VBのテキストボックスはEDITクラスを持ったオブジェクトを、VBでコンポーネント化したものです。



VBのラベルはハンドルを持たずに、フォームに直接描かれていると思いました。
（現在OS再インストールしたばかりで、未確認です）
これが何を意味するかというと、ラベルはVBの仕様以上のことができないということです。ですのでラベルだけでの制御では無理だと思います。

EDITボックスは、プロパティで指定されているフォントで、文字コードを表現しているだけです。


私の場合、思いつく実現方法として、二つあると思います。

※1.フォントを登録する
これなら、ラベルでもテキストボックスでも可能です。
たしかVBでオリジナルのスクリーンフォントの登録ができたと思います・・・が自信はありません。
遠い記憶で、同僚がやっていたような気が・・・


※2.ピクチャに描画し、縦か横を倍サイズ領域のピクチャボックスに転送する。
ここの掲示板の履歴に、PaintPicture/StretchBlt/BitBltなどの画像転送サンプルが転がっていると思います。
（こっちの方が実用的かな？）

sha-girl · Answer

CreateFont APIは使えば縦長、横長、回転した文字を
ピクチャーボックスで表示できるので
ピクチャーボックスを使ってみてはどうでしょうか？

hDCを取得できればラベルやテキストボックスでも
CreateFont APIで可能かもしれません。

VBで横倍角/縦倍角を表示したいのですが

>ラベルやテキストボックスに横倍角や縦倍角の文字を表示することは可能でしょうか。

CreateFont APIは使えば縦長、横長、回転した文字を

先に回答されている方と同じ理由でやはりピクチャーボックスでの方法です。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング