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("ＭＳ ゴシック", 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で行っております。
以下のようなコードですが、うまく終了してくれません。
'グローバル
'プリンタの状態
Dim BUF as String
'起動時
Private Sub Form_Load()
MSComm1.PortOpen = True
Text1.Text = ""
Timer1.Enabled = True
End Sub
'終了
Private Sub Form_Unload(Cancel As Integer)
Timer1.Enabled = False
MSComm1.PortOpen = False
End Sub
'タイマー
Private Sub Timer1_Timer()
Timer1.Enabled = False
Call CheckPrint
Timer1.Enabled = True
End Sub
Private Sub MSComm1_OnComm()
Dim TimeOut As Long
Dim sTime As Long
Dim eTime As Long
Select Case MSComm1.CommEvent
'受信
Case comEvReceive
TimeOut = 100
sTime = timeGetTime
Do
If (TimeOut - eTime) < 0 Then
Exit Do
End If
eTime = (timeGetTime - sTime)
Loop Until MSComm1.InBufferCount >= 82
BUF = MSComm1.Input
End Select
End Sub
プリンタの状態チェック
Private Sub CheckPrint()
Dim sTime As Long
Dim eTime As Long
Dim TimeOut As Long
Dim i As Integer
Dim n As Integer
BUF = ""
'プリンタの情報取得コマンド
MSComm1.Output = "~HS"
'タイマ開始
TimeOut = 400
sTime = timeGetTime
eTime = 0
Do
DoEvents
If BUF <> "" Then
Exit Do
End If
eTime = (timeGetTime - sTime)
Loop Until TimeOut - eTime < 0
If BUF <> "" Then
...
..
宜しくお願いします。
以下の２つは同じ意味だと思うのですが、test2はエラーになります。どうしてなのでしょうか？
Sub test1()
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 300#, 100#, 140#, 80#).Select
Selection.Formula = "$A$1"
End Sub
Sub test2()
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, 300#, 100#, 140#, 80#)
.Formula = "$A$1"
End With
End Sub
入力したデータの一番下にの行に"data_end"と入力するようにしたいと思っております。
今、UsedRangeを使用してその下の行に"data_end"と入力しようとすると以前に使用した行まで選ばれてしまい、空白の行ができてしまう状態になっています。また、CurrentRegionを使用すると空白行があると空白行以降を選んでもらえません。（データがトビトビにあるので空白行と認識されてしまう可能性があります。）
しかも、データの入力されているセルは別のシートで計算式に参照されているのでいらない行を削除することはできません。
今入力されている状態の一番下の行を認識するにはどうしたらよいでしょうか？
プログラムは以下のように入力してあります。
Sub test()
Dim row_end As Integer
Sheets("sheet1").Select
ActiveSheet.UsedRange.Select
row_end = Selection.Rows.Count
Sheets("sheet1").Cells(row_end + 1, 1).Value = "data_end"
End Sub
ものすごく基本的な質問かもしれませんが、よろしくお願いしますっっっ。
エクセルで名簿を作ろうとしています。よくあることですが、入力を簡単にするため、入力メニューを作り、一人目を入力したら次の行に行くようにマクロを考えているのですが、その前に最初のセルを選択させようと下記のように記述したところ、コンパイル時に実行時エラー'1004'アプリケーション定義またはオブジェクト定義エラーです。というエラーになります。
また、作成したコマンドボタンから実行しても実行時エラー'1004'RangeクラスのSelectメソッドが失敗しましたというエラーになります。
Rangeオブジェクトの記載の仕方は間違いないと思うのですが....ちなみに書こうとしている意味は、表が、全く登録がない場合、最初B2セルから記載していくように考え、追加登録していくときはB1セル（項目に当たる行）から空白行になるまで改行するように考えました。
記述内容
Sub CommandButton1_Click()
Worksheets("名簿").Select
If Range("B2").Value = "" Then
Range("B2").Select ←エラーになる行です
Else
Range("B1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
End If
名簿登録.Show
End Sub
