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

質問

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

回答No.3

taisuke555 · ベストアンサー

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

'*******************************************************
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にも同じ様に印刷されるので、
イメージ表示の感じになるのではないでしょうか？
今回は倍角についての質問でしたので、斜体、下線、太字等の設定は固定にしてあります。

お礼

ありがとうございました。
参考ソースまでいただき、大変助かりました。
早速ソース解析し、組み込んでみます。

回答No.2

sha-girl

CreateFont APIは使えば縦長、横長、回転した文字を
ピクチャーボックスで表示できるので
ピクチャーボックスを使ってみてはどうでしょうか？

hDCを取得できればラベルやテキストボックスでも
CreateFont APIで可能かもしれません。

お礼

ありがとうございました。
ピクチャボックスを使うことにしました。

回答No.1

TAGOSAKU7

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

概念から説明しましょう。
VBのラベルは、WINDOWSは絵として認識しています。
VBのテキストボックスはEDITクラスを持ったオブジェクトを、VBでコンポーネント化したものです。

VBのラベルはハンドルを持たずに、フォームに直接描かれていると思いました。
（現在OS再インストールしたばかりで、未確認です）
これが何を意味するかというと、ラベルはVBの仕様以上のことができないということです。ですのでラベルだけでの制御では無理だと思います。

EDITボックスは、プロパティで指定されているフォントで、文字コードを表現しているだけです。

私の場合、思いつく実現方法として、二つあると思います。

※1.フォントを登録する
これなら、ラベルでもテキストボックスでも可能です。
たしかVBでオリジナルのスクリーンフォントの登録ができたと思います・・・が自信はありません。
遠い記憶で、同僚がやっていたような気が・・・

※2.ピクチャに描画し、縦か横を倍サイズ領域のピクチャボックスに転送する。
ここの掲示板の履歴に、PaintPicture/StretchBlt/BitBltなどの画像転送サンプルが転がっていると思います。
（こっちの方が実用的かな？）

お礼

ありがとうございました。
ピクチャボックスを使うことにしました。