こんにちは。maruru01です。
APIのCreateFont関数を使用して文字列を回転させ、それを印刷しようとしたのですが、うまくいきません。
どうもCreateFontの情報がPrinterオブジェクトに伝わってないようです。
オブジェクトをPrinterの替わりにForm1にするとちゃんと回転して表示されます。
どうすればうまくいくのでしょうか。
よろしくお願いします。

使用環境:Windows2000(SP2)、Visual Basic 6.0(SP5) EnterpriseEdition


Private Sub Command1_Click()

  Dim hdc As Long
  Dim FontName As String
  Dim FontHeight As Long
  Dim hFont As Long
  Dim hFontOld As Long
  Dim tempStr As String
  
  Const DEFAULT_CHARSET = 1
  
  tempStr = "文字列回転"
  
  hdc = Printer.hdc
  FontName = "MS Pゴシック"
  FontHeight = 9
  hFont = CreateFont(-(FontHeight * 20 / Screen.TwipsPerPixelX), 0, 900, 2700, 0, False, False, False, DEFAULT_CHARSET, False, False, False, False, FontName)
  hFontOld = SelectObject(hdc, hFont)
  
  Printer.ScaleMode = vbCentimeters
  Printer.CurrentX = 2
  Printer.CurrentY = 2
  Printer.Print tempStr
  
  DeleteObject SelectObject(hdc, hFontOld)
  
End Sub

A 回答 (3件)

>どうもCreateFontの情報がPrinterオブジェクトに伝わってないようです。



VBの制限事項です。→参考URL

>どうすればうまくいくのでしょうか。

Printer.Printではなく、TextOutを使いましょう。

参考URL:http://www.microsoft.com/japan/support/kb/articl …
    • good
    • 0
この回答へのお礼

回答ありがとうございます。
実はTextOutも下のように使ったんですが、やはりうまくいきませんでした。

Result = TextOut(hdc, OffsetX, OffsetY, tempStr, LenB(StrConv(tempStr, vbFromUnicode)))

どこが悪いのでしょうか。ちょっと八方塞がりの状態です。
とりあえず、参考URLありがとうございました。

お礼日時:2002/01/07 19:01

回転文字の件は確か下記のMLの過去ログで見た記憶があります。


ただ過去ログの番号を忘れました。

そこで紹介されていたコードを下記に載せておきます。
ちなみに私はAPIには疎いので、動作の理屈がわかりませんが。
------------------------------------------------------
Option Explicit
Private 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
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 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 Sub Form_Paint()
Dim Responce
Dim FontHandle As Long
Dim OldFontHandle As Long
Dim ResultCode As Long
Dim TargetDcHandle As Long
Dim strMsg As String

Responce = MsgBox("文字列を印刷しますか", 4, "")

'描画対象のデバイスコンテキストをフォームに設定
TargetDcHandle = Form1.hDc
'描画文字列の設定
strMsg = "文字列"

'論理フォントの作成
FontHandle = CreateFont(48, 24, 400, 0, 0, 0, 0, _
0, 1, 0, 0, 0, 0, "MS 明朝")
'作成した論理フォントを描画対象のデバイスコンテキストに割り当てる
OldFontHandle = SelectObject(TargetDcHandle, FontHandle)
'文字列を描画する
ResultCode = TextOut(TargetDcHandle, 10, 100, strMsg, _
LenB(StrConv(strMsg, vbFromUnicode)))

'元のフォントオブジェクトに戻す
ResultCode = SelectObject(TargetDcHandle, OldFontHandle)
'作成した論理フォントを削除する
ResultCode = DeleteObject(FontHandle)

If Responce = vbYes Then
'描画対象のデバイスコンテキストをプリンタに設定
TargetDcHandle = Printer.hDc
'描画文字列の設定
strMsg = "文字列"

Printer.Print ""

'論理フォントの作成
FontHandle = CreateFont(48, 24, 300, 0, 0, 0, 0, _
0, 1, 0, 0, 0, 0, "MS 明朝")

'作成した論理フォントを描画対象のデバイスコンテキストに割り当てる
OldFontHandle = SelectObject(TargetDcHandle, FontHandle)
'文字列を印刷する
ResultCode = TextOut(TargetDcHandle, 10, 100, strMsg, _
LenB(StrConv(strMsg, vbFromUnicode)))
Printer.EndDoc

'元のフォントオブジェクトに戻す
ResultCode = SelectObject(TargetDcHandle, OldFontHandle)
'作成した論理フォントを削除する
ResultCode = DeleteObject(FontHandle)
End If
End Sub

参考URL:http://dev.sfdata.ne.jp/VB/search.html
    • good
    • 0
この回答へのお礼

回答ありがとうございます。
実は書いていただいた内容は、私も見たことがあります。
結局、PrinterのLineメソッドを、CreateFontの後に使用していたのが原因のようで、先にLineメソッドで線(四角)を書いて、その後でCreateFontでフォントを作成して、TextOutを使用すると、一応文字列は回転しました。
どうもありがとうございました。

お礼日時:2002/01/08 14:43

今VB4環境で、しかもMSDNが手元にないので、調べる事ができません。



ですので回避方法として、非表示のピクチャボックスに描画して、それをプリントアウトではだめですか?
フォームもピクチャボックスも内部では一緒だから、手っ取り早い回避方法だと思いますが。。。

やっぱダメ?
    • good
    • 0
この回答へのお礼

回答ありがとうございます。
>非表示のピクチャボックスに描画して、それをプリントアウトではだめですか?
PrintFormメソッドのことですよね。
実際には絵も一緒に印刷するので、PrintFormでは画質が問題で使えないんです。
なんにしろ、早い回答ありがとうございました。

お礼日時:2002/01/07 18:55

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

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

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

QVBからプリンタに出力する時に印刷方向を縦から横に変更したいのですが・・・

横長のフォームをそのまま印刷したいのですが、そのままPrintformで
印刷すると、全体が印刷されずに横が切れてしまって困ってます。
印刷方向を横に変更する方法がわからないし、用紙に合わせてサイズを変更
というようなこともいくらか調べてみたのですが、手元の解説書、数冊を
読んでみても全くやりかたが分からなくて困ってます。

フリーの印刷関係のモジュールなんかでもいいので、いい方法を教えてください。

頼まれたプログラムを完成させなければならない期限がもうすぐなので、
出来るだけ早く知りたいです。どうかよろしくお願いします。

Aベストアンサー

用紙方向はPrinterオブジェクトのプロパティで変更できます。
横向きは
Printer.Orientation = vbPRORLandscape
縦向きは
Printer.Orientation = vbPRORPortrait

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

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

Aベストアンサー

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

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

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

'*******************************************************
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 Co...続きを読む

QSPREAD(GrapeCity)のセルにフォーカスを設定するにはどうしたらいいのでしょうか?

VB.netで作成しています。
SPREAD(GrapeCity)の下記のイベントでSPREADのセルに入力された値をチェックしてエラーが無ければデータベースに登録、または更新をして入力エラーがあった場合、セルにフォーカスを設定するように記述していますがうまくフォーカスを設定する事ができません。

・SPREADのChangeイベント
・SPREADのKeyUpイベント
・SPREADのLeaveイベント
・SPREADのCellLeaveイベント

フォーカスを当てたいセルの行番号とカラム番号をSetActiveCellで指定していますが・・・
フォーカスを設定するにはどうしたらいいのでしょうか?
ご存知の方がいましたらアドバイス宜しくお願いします。
では、失礼します。

Aベストアンサー

サポートページを見ただけなので参考程度にお願いします。
http://file.grapecity.com/patches/SPREADNET25Win_ReleaseNote_2510122002.htm

上記ページの「制限事項と注意点」→「【イベント/メソッド】 」の中に「シート上に表示されていないセルに対してSetActiveCellメソッド呼び出し(またはActiveRowIndex/ActiveColumnIndexプロパティの設定)を行った場合、シートは自動的にスクロールされません。表示させる場合にはFpSpreadクラスのShowActiveCellメソッドを併用してください。 」とあります。
一度試してみては?
また、GrapeCityさんは意外とサポートが優秀ですよ。
以前、SPREADver3.0の頃は何回かバグとってもらいました。(非公開で最新ファイルくれました)
バグでなくても親切に対応してもらった覚えがあるので一度問い合わせをしたほうが近道かもしれませんね。

QSPREADでカーソルの位置を1行目に戻したいなぁ

VB6とSPREADver7.0を使っています。
SPREADのOperationModeプロパティは2(行モード)です。
初期状態で、SPREADカーソルの位置は1行目にあります。
SPREADの2行目以下の行を選択し、ボタン押下で
SPREADカーソルの位置を1行目に戻す処理を知りたいのです(泣
RowcountやRecordCountを使うやり方があると聞いたのですが・・・ 
どなたかわかる方よろしくお願いします。

Aベストアンサー

SetActiveCell ?

QGetTextExtentPoint32での高さ

こんにちは。
数字が入った文字列をGetTextExtentPoint32関数で幅と高さを取得しようとすると、幅は正しく取得できるのですが、高さが倍近い値で返ってきてしまいます。どうやら高さはフォント全体の高さで取得しているようです。"0123"と"0123j"をセットしても同じ高さが返ってきます。
これを実際の描画範囲で取得するにはどうすればよろしいのでしょうか?

Aベストアンサー

幅については描画する範囲がプロポーショナルピッチによる幅の変動する為、取得する必要がありますが、
高さについては文字(といか行)毎に上下することはない(上下するようでは見にくい)ということから、指定したフォントで設定されている値がそのまま返却されるのでしょう。
それでも「描画される最小矩形」が必要なのでしょうか?
画面更新時はなるべく最小矩形の方が処理量は減るかと思われますが、現在のPCならドライバ任せでも問題になるような差は出ないと思われますが……。

それでも取得したい。
ということであれば文字列を分解してGetGlyphOutline()で取得することで1文字のフォントでの矩形サイズが取得できるでしょう。
ただし、文字描画の際にはベースラインなどを考慮しますので、ベースラインをそろえた上で算出する必要がありますが……
http://marupeke296.com/WINT_GetGlyphOutline.html
辺りが図になっているのでわかりやすい…でしょうかね。

各文字のグリフを取得した後、「ベースラインより上」と「ベースラインより下」のサイズをそれぞれ算出し、必要な文字フォント分の処理を終えた後で加算すればよいでしょう。
# uCharの設定がいろいろと手間…でしょうかね。(UNICODEならそれほどでもないかも知れませんが…SJISだと面倒)
# uFormatも…かな。アンチエイリアス有りと無しでは取得できるサイズが変わるでしょうし。
# cbBufferは0、lpvBufferはNULLでもかまわない…かも知れません。

使用する文字によっては… (gmBlackBoxY - gmGlyphOrign.y)がマイナスになってしまう場合もあるのでご注意を。
# "-"等、ベースラインより上だけで済んでしまうものの場合とか。

幅については描画する範囲がプロポーショナルピッチによる幅の変動する為、取得する必要がありますが、
高さについては文字(といか行)毎に上下することはない(上下するようでは見にくい)ということから、指定したフォントで設定されている値がそのまま返却されるのでしょう。
それでも「描画される最小矩形」が必要なのでしょうか?
画面更新時はなるべく最小矩形の方が処理量は減るかと思われますが、現在のPCならドライバ任せでも問題になるような差は出ないと思われますが……。

それでも取得したい。
というこ...続きを読む

QVB6 APIを使った文字印刷について

VB6でAPI(TextOut)を使って印刷する必要があるのですが、インターネットで調べたらサンプルがあってそれを参考にさせてもらおうと思っています。

ただ、当方としては、印刷位置と印刷文字サイズをmmで指定したく、色々試しているのですがうまくいきません。お分かりになる方どこがおかしいかご教示願えないでしょうか?
サンプルのソースコードを以下に張っておきます。formにCommandボタンを一つ張ってください。

Option Explicit

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()
Printer.Print ""

'文字印刷位置縦0mm 文字幅6mm、文字高6mmで印刷
FX = 6: FY = 6
cx = 0: cy = 0
PrintText "testてすと1"

'文字印刷位置縦50mm 文字幅6mm、文字高12mmで印刷
FX = 6: FY = 12
cx = 0: cy = 50
PrintText "testてすと2" '縦倍角

'文字印刷位置縦200mm 文字幅12mm、文字高6mmで印刷
FX = 12: FY = 6
cx = 0: cy = 100
PrintText "testてすと3" '横倍角

Printer.EndDoc

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 PX As Long
Dim PY As Long


hdc = Printer.hdc

'↓(1)ここで文字印刷位置をmmかTwipに変換しているつもりなのですが・・・
PX = Printer.ScaleX(cx, vbMillimeters, vbTwips)
PY = Printer.ScaleY(cy, vbMillimeters, vbTwips)

With LF
.lfEscapement = 0 '文字の回転角度(角度*10)

'↓(2)ここで文字サイズをmmかTwipに変換しているつもりなのですが・・・
.lfHeight = Printer.ScaleY(FY, vbMillimeters, vbTwips) '文字の高さ
.lfWidth = Printer.ScaleX(FX, vbMillimeters, vbTwips) '文字の幅

.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("MS ゴシック", vbFromUnicode)
ByteArrayLimit = UBound(TempByteArray)

For IX = 0 To ByteArrayLimit
.lfFaceName(IX) = TempByteArray(IX)
Next

End With

NewFT = CreateFontIndirect(LF)
OldFT = SelectObject(hdc, NewFT)

TextOut hdc, PX, PY, text, LenB(StrConv(text, vbFromUnicode))

rtn = SelectObject(hdc, OldFT)
rtn = DeleteObject(NewFT)

End Sub

以上よろしくおねがいします。

VB6でAPI(TextOut)を使って印刷する必要があるのですが、インターネットで調べたらサンプルがあってそれを参考にさせてもらおうと思っています。

ただ、当方としては、印刷位置と印刷文字サイズをmmで指定したく、色々試しているのですがうまくいきません。お分かりになる方どこがおかしいかご教示願えないでしょうか?
サンプルのソースコードを以下に張っておきます。formにCommandボタンを一つ張ってください。

Option Explicit

Dim FX As Integer 'フォントの横サイズ
Dim FY As Integer 'フォントの縦サイ...続きを読む

Aベストアンサー

もう解決しましたか?
何日か経過しているので、お気づきかもしれませんし、
自分の推測による回答ですので、間違っていたらごめんなさい。

1.TextOut も フォントサイズもpixel指定になっていると思います。

質問のプログラムに下記を追加し、コマンドボタンを1つ追加して実行してみてください。
文字幅は半角文字のサイズのようです。

Private Sub Command2_Click()
  FX = 6     '通常のフォント
  FontTest1 "t"
  
  FX = 0: FY = 6 '幅を0にすると高さに合わせて調整する
  FontTest2 "t"

  FX = 6: FY = 6 '半角の幅?
  FontTest2 "t"
End Sub

Private Sub FontTest1(text As String)
  Dim rtn As Long
  Dim hdc As Long
  Dim sz As Size
  
  '通常のサイズ
  Printer.FontName = "MS ゴシック"
  Printer.FontSize = CLng(Printer.ScaleX(FX, vbMillimeters, vbPoints))
  
  hdc = Printer.hdc
  rtn = GetTextExtentPoint32(hdc, text, LenB(StrConv(text, vbFromUnicode)), sz)
  MsgBox "[" & text & "] (" & CLng(Printer.ScaleX(FX, vbMillimeters, vbPoints)) & _
        ") = (" & sz.cx & "," & sz.cy & ")"
End Sub

Sub FontTest2(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
  
  hdc = Printer.hdc
  
  With LF
    .lfEscapement = 0 '文字の回転角度(角度*10)
  
    '↓(2)ここで文字サイズをmmかTwipに変換しているつもりなのですが・・・
    .lfHeight = Printer.ScaleY(FY, vbMillimeters, vbPixels) '文字の高さ
    .lfWidth = Printer.ScaleX(FX, vbMillimeters, vbPixels) '文字の幅
  
    .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("MS ゴシック", vbFromUnicode)
    ByteArrayLimit = UBound(TempByteArray)
  
    For IX = 0 To ByteArrayLimit
      .lfFaceName(IX) = TempByteArray(IX)
    Next
  End With
  
  NewFT = CreateFontIndirect(LF)
  OldFT = SelectObject(hdc, NewFT)
  
  rtn = GetTextExtentPoint32(hdc, text, LenB(StrConv(text, vbFromUnicode)), sz)
  MsgBox "[" & text & "] (幅,高さ) = (" & LF.lfWidth & "," & LF.lfHeight & ")→(" & sz.cx & "," & sz.cy & ")"
  
  rtn = SelectObject(hdc, OldFT)
  rtn = DeleteObject(NewFT)
End Sub

2.あと印刷位置の方ですが、印刷不可能領域の問題があると思います。
たとえば、Pinrter.Line (0,0)-(1000,1000),,b
を実行してみると、紙の左上ではなく、印刷可能領域の左上が(0,0)の位置になると思います。
ふちなし印刷とかですと端からかもしれませんが、私のプリンタでは上左3mmほど内側になりました
プリンタによって違うと思いますので、その辺も考慮に入れないといけないと思います。

もう解決しましたか?
何日か経過しているので、お気づきかもしれませんし、
自分の推測による回答ですので、間違っていたらごめんなさい。

1.TextOut も フォントサイズもpixel指定になっていると思います。

質問のプログラムに下記を追加し、コマンドボタンを1つ追加して実行してみてください。
文字幅は半角文字のサイズのようです。

Private Sub Command2_Click()
  FX = 6     '通常のフォント
  FontTest1 "t"
  
  FX = 0: FY = 6 '幅を0にすると高さに合わせて調整する
  FontTest2...続きを読む

QCreateFontのフォントの高さについて

こんにちは。

CreateFontのフォントの高さについて教えてください。

ポイント数で指定されたフォントサイズを変換して、
フォントの高さ、フォントの幅に設定したいのですが、
よくわかりません。

マッピングモードがMM_TEXTの場合は、下記でフォントの高さを変換し、
幅には0を指定すればOKのようです。
nHeight = -MulDiv(PointSize, GetDeviceCaps(hDC, LOGPIXELSY), 72);

しかし、今回、マッピングモードがMM_HIMETRICなのですが、
この場合は、どのようにして変換すればよいのでしょうか?

MFCは使用しません。
よろしくお願いいたします。

Aベストアンサー

MM_HIMETRICは1ピクセルが0.01mmという非常に細かい単位で設定されるマッピングです。
これで1インチの長さを求めると約2.54cmだから2540ピクセルになりますね。
これがMM_TEXT時でのGetDeviceCapsで求めた高さと同じになります。
だから式としては、
nHeight = -MulDiv(PointSize, 2540, 72);
…となるはずですが。どうでしょう…間違っていたらすみません ^^;

QVB.NETのコンボボックスについて

VB6からVB.NETでプログラミングを始めました。
コンボボックスのクリアの仕方や設定の仕方、また
取り出し方等を教えて下さい。

色々とヘルプも見てみたのですが、よく解りません。
宜しくお願い致します。

Aベストアンサー

クリアだけだと思ってました。
追記します。

Itemを操作します


'登録
For i = 1 To 10
  Me.ComboBox1.Items.Add(i.ToString)
Next

'取得
For i = 0 To Me.ComboBox1.Items.Count - 1
  MsgBox(Me.ComboBox1.Items(i).ToString)
Next

'完全クリア
Me.ComboBox1.Items.Clear()

部分クリア
Me.ComboBox1.Items.RemoveAt(Index値)

QVB6 配列を初期化したい

VB6でループさせて配列に値を入れて、計算させて最終的に求めたい値をRとします。そのときループで繰り返すためか同じ配列に値を入れてどんどん値がでかくなりRの値がおかしくなってしまいます;
おそらく問題は一回前に入れた配列がそのままのこってしまってるからなのだと思うのですが;
配列の中の値をクリアする方法はないものでしょうか?
一応、配列=0として初期化しようとしても値は変わらず前のが残ったままになってしまっています;
どなたかわかる方いらっしゃいましたらご回答宜しくお願いします

その他何かいい方法があればそれも教えていただけたらと思います

Aベストアンサー

Eraceステートメントを使用

  Dim a() as Long
  Dim s(100) as String
  Dim x() as Long

  Erase a     ’要素が0になる
  Erase s     ’要素が""になる

  Redim x(100) as Long

  Erase x      ’メモリを解放

注)VB2005の場合は動作が異なるので注意して下さい。

Qプロポーショナルフォントの文字列から印刷幅を求める関数

フォントと文字列を指定して必要なピクセル数を求める関数はありますか

備考欄なのですが2文字程度のあふれなら縮小、それ以上なら改行して全体表示させるマクロを作りたいのです

固定長フォントにすれば文字数から判断できますがPフォントなので

別シートに該当文字列を入れてAutoFitして求めることも考えましたがあまりスマートじゃないで
何かで見た記憶があるのですがVBAじゃなかったのか探しても見つから無かったので質問させていただきます。

Aベストアンサー

検索してみたら、APIのGetTextExtentPoint32関数で取れそうな感じですが...
http://msdn.microsoft.com/ja-jp/library/cc410400.aspx
よくわかってないのでハズしてたらすみません。

『No16666.テキストボックスからはみ出た文字を削除する方法』
http://www.accessclub.jp/bbs2/0051/beginter16666.html
ここを参考にテストしてみて、Pフォントの各文字幅が取れるところまでは確認しました。(文字列全体も)
Function GetTextExtent にControlではなくFontを渡すように修正したり、
dxdy.cx取得後の変換が必要だったりするような感じではありますが。


人気Q&Aランキング