List 7-42 FormPrintPreviewフォームのDrawPreviewプロシージャ
1： Private Sub myLine(ByRef objPic As Object, _
x1 As Long, y1 As Long, _
x2 As Long, y2 As Long, _
drawFlag As Boolean)
2： ' objPicにLineメソッドを使って線を描画する
3： ' 【引数】
4： ' objPic = 描画対象となるオブジェクト
5： ' ピクチャボックスかPrinterオブジェクトのいずれか
6： ' (x1, y1) = 始点座標
7： ' (x2, y2) = 終点座標
8： ' drawFlag = 実際に描画するかどうかのフラグ。
9： ' 描画するときはTrue，
10： ' 描画せずカレント位置を変更するだけのときにはFalse
11： ' 【戻り値】
12： ' なし
13：
14： If drawFlag Then
15： ' 描画する
16： objPic.Line (x1, y1)-(x2, y2)
17： Else
18： ' 描画しない
19： objPic.CurrentX = x2
20： objPic.CurrentY = y2
21： End If
22： End Sub
23：
24： Private Sub myPrint(ByRef objPic As Object, _
Value As Variant, _
drawFlag As Boolean)
25： ' objPicにPrintメソッドを使って描画する
26： ' 【引数】
27： ' objPic = 描画対象となるオブジェクト
28： ' ピクチャボックスかPrinterオブジェクトのいずれか
29： ' Value = 描画するテキスト
30： ' drawFlag = 実際に描画するかどうかのフラグ。
31： ' 描画するときはTrue，
32： ' 描画せずカレント位置を変更するだけのときにはFalse
33： ' 【戻り値】
34： ' なし
35： If drawFlag Then
36： ' 描画する
37： objPic.Print Value
38： Else
39： ' 描画しない
40： objPic.CurrentX = objPic.CurrentX + objPic.TextWidth(Value)
41： objPic.CurrentY = objPic.CurrentY + objPic.TextHeight(Value) 42： End If
43： End Sub
44：
45： Private Function DrawBox(ByRef objDoc As Object, _
ByVal Text As String, _
ByVal ColumnWidth As Long, _
ByVal Alignment As Long, _
ByVal drawFlag As Boolean) As Long
46： ' 指定された幅に収まるように折り返して，テキストを描画する
47： ' 【引数】
48： ' objDoc = 描画対象となるオブジェクト
49： ' ピクチャボックスかPrinterオブジェクトのいずれか
50： ' Text = 描画する文字列
51： ' ColumnWidth = 描画幅
52： ' Alignment = 文字揃え
53： ' dbgGeneral（標準。文字ならば左揃え，数値ならば右揃え）
54： ' dbgLeft（左揃え）
55： ' dbgRight（右揃え）
56： ' dbgCenter（中央揃え）
57： ' のいずれか
58： ' drawFlag = 実際に描画するかどうかのフラグ。
59： ' 描画するときはTrue，
60： ' 描画せずカレント位置を変更するだけのときにはFalse
61： ' 【戻り値】
62： ' 描画したテキストの高さを返す
63：
64： Const OffsetX = 56 ' 表示オフセットはここでは約1mmとする
65： Const OffsetY = 56 ' 表示オフセットはここでは約1mmとする
66：
67： Dim txHeight As Long
68： Dim i As Long
69： Dim putText As String
70： Dim X As Long, Y As Long
71： Dim orgX As Long, orgY As Long
72：
73： i = 1
74： txHeight = 0
75： orgX = objDoc.CurrentX
76： orgY = objDoc.CurrentY
77： 78： X = orgX + OffsetX
79： objDoc.CurrentX = X
80：
81： ColumnWidth = ColumnWidth - OffsetX
82： Y = orgY + OffsetY
83： objDoc.CurrentY = Y
84：
85： If ColumnWidth <= 0 Then
86： ' 幅が0の場合には，表示しない
87： DrawBox = 0
88： Exit Function
89： End If
90：
91：
92： ' 揃えがデフォルトのとき
93： If Alignment = dbgGeneral Then
94： ' デフォルト
95： ' テキストならば左揃え，数値ならば右揃え
96： If IsNumeric(Text) Then
97： ' 数値なので右揃え 98： Alignment = dbgRight
99： Else
100： ' 文字なので左揃え
101： Alignment = dbgLeft
102： End If
103： End If
104：
105： ' 横幅からはみ出さない部分だけ折り返して表示するループ処理
106： Do
107： ' 横幅からはみ出さない部分だけをputText変数に格納する
108： putText = ""
109： While (objDoc.TextWidth(putText) < ColumnWidth) And (i <= Len(Text))
110： putText = putText & Mid(Text, i, 1)
111： i = i + 1
112： Wend
113：
114： If objDoc.TextWidth(putText) > ColumnWidth Then
115： putText = Left(putText, Len(putText) - 1)
116： i = i - 1
117： End If
118：
119： ' 揃えごとの処理
120： Select Case Alignment
121： Case dbgRight
122： ' 右揃え
123： objDoc.CurrentX = X + ColumnWidth - objDoc.TextWidth(putText)
124： Case dbgCenter
125： ' 中央揃え
126： objDoc.CurrentX = X + (ColumnWidth - objDoc.TextWidth(putText)) / 2
127： Case Else
128： ' 左揃え
129： objDoc.CurrentX = X
130： End Select
131： ' 文字を描画する
132： myPrint objDoc, putText, drawFlag
133： objDoc.CurrentX = X
134： txHeight = txHeight + objDoc.TextHeight(putText)
135： Loop While i <= Len(Text)
136：
137： objDoc.CurrentX = orgX
138： objDoc.CurrentY = orgY
139：
140： DrawBox = txHeight + OffsetY * 2
141： End Function
142：
143： Private Function DrawPreview(ByRef objPic As Object, _
ByRef StartPage As Long, _
ByRef EndPage As Long) As Long
144： ' プレビュー画面を描画する
145： ' 【引数】
146： ' objDoc = 描画対象となるオブジェクト
147： ' ピクチャボックスかPrinterオブジェクトのいずれか
148： ' StartPage = 先頭ページ番号
149： ' EndPage = 最終ページ番号
150： ' 【戻り値】
151： ' -1 = エラー
152： ' 正の数 = 出力した最終ページ番号
153： Dim row As Long, col As Long, i As Long
154： Dim objRec As ADODB.Recordset
155： Dim newPageFlag As Boolean
156： Dim columnNum As Long
157： Dim colWidth() As Long
158： Dim colIndex() As Long
159： Dim VisibleNum As Long
160： Dim X As Long, Y As Long
161： Dim MLeft As Long, MRight As Long, MUp As Long, MDown As Long
162： Dim ColWidthTotal As Long
163： Dim ColHeight As Long, ColMaxHeight As Long
164： Dim NowPage As Long
165： Dim BookMark As Variant, oldBookMark As Variant
166： Dim drawFlag As Boolean
167：
168： ' 余白情報の取得
169： If Not IsNumeric(TXT_UP.Text) Then
170： MsgBox "上余白が不正です", vbOKOnly, "印刷エラー"
171： DrawPreview = -1
172： Exit Function
173： Else
174： MUp = CLng(TXT_UP.Text)
175： End If
176：
177： If Not IsNumeric(TXT_DOWN.Text) Then
178： MsgBox "下余白が不正です", vbOKOnly, "印刷エラー"
179： DrawPreview = -1
180： Exit Function
181： Else
182： MDown = CLng(TXT_DOWN.Text) 183： End If
184：
185： If Not IsNumeric(TXT_LEFT.Text) Then
186： MsgBox "左余白が不正です", vbOKOnly, "印刷エラー"
187： DrawPreview = -1
188： Exit Function
189： Else
190： MLeft = CLng(TXT_LEFT.Text)
191： End If
192：
193： If Not IsNumeric(TXT_RIGHT.Text) Then
194： MsgBox "右余白が不正です", vbOKOnly, "印刷エラー"
195： DrawPreview = -1
196： Exit Function
197： Else
198： MRight = CLng(TXT_RIGHT.Text)
199： End If
200：
201： On Error GoTo ErrHandle
202：
203： ' 余白をmm単位からTwip単位に変換する
204： MUp = objPic.ScaleY(MUp,vbMillimeters, vbTwips)
205： MDown = objPic.ScaleY(MDown, vbMillimeters, vbTwips)
206： MLeft = objPic.ScaleX(MLeft, vbMillimeters, vbTwips)
207： MRight = objPic.ScaleX(MRight, vbMillimeters, vbTwips)
208：
209： Set objRec = g_DGrid.DataSource
210：
211： newPageFlag = True
212： NowPage = 1
213：
214： If (NowPage >= StartPage) And (NowPage <= EndPage) Then
215： ' 表示する
216： drawFlag = True
217： Else
218： ' 表示しない
219： drawFlag = False
220： End If
221：
222： ' DataGridコントロールの列数を取得
223： columnNum = g_DGrid.Columns.Count
224：
225： ' 列の幅を算出する
226： ' 用紙の横幅に合わせた形に表を引き延ばし，
227： ' もとのDataGridの列幅と比例する形で
228： ' 各列を分配する形で幅を求める
229： ' ただし，このとき，非表示の列は除く
230：
231： ReDim colWidth(columnNum)
232： ReDim colIndex(columnNum)
233：
234： ColWidthTotal = 0
235： VisibleNum = 0
236：
237： ' 各列の幅と，各列の幅の総和を求める
238： ' また，表示されている列の列番号（Columnオブジェクトのインデックス番号）を
239： ' colIndex配列に格納しておく
240： For i = 0 To columnNum - 1
241： If g_DGrid.Columns(i).Visible Then
242： ' 表示されているとき
243： colWidth(VisibleNum) = g_DGrid.Columns(i).Width
244： ColWidthTotal = ColWidthTotal + g_DGrid.Columns(i).Width
245： colIndex(VisibleNum) = i
246： VisibleNum = VisibleNum + 1
247： End If
248： Next
249：
250： ' 各列の幅が合うように揃える
251： For i = 0 To VisibleNum - 1
252： colWidth(i) = colWidth(i) * (objPic.Width - MLeft - MRight) * / ColWidthTotal
253： Next
254：
255： ' ページの印刷を開始
256：
257： ' カレント座標を左上の余白内位置に移動する
258： objPic.CurrentX = MLeft
259： objPic.CurrentY = MUp
260：
261： ' タイトルの印刷
262： If NowPage = 1 Then
263： ' 先頭ぺージであれば，タイトルを表示する
264： Dim oldFont As Font
265： Set oldFont = objPic.Font
266： Set objPic.Font = New StdFont
267： myPrint objPic, g_Title, drawFlag
268： myPrint objPic, "", drawFlag
269： myPrint objPic, "", drawFlag
270： Set objPic.Font = objPic.Font
271： End If
272：
273： ' 行を次々と表示する
274： Y = objPic.CurrentY
275：
276： ' その時点のブックマーク位置を保存しておく
277： oldBookMark = g_DGrid.BookMark
278：
279： ' レコードを先頭に移動する
280： objRec.MoveFirst
281：
282： ' レコード数だけループして各列を描画する
283： For row = 0 To objRec.RecordCount - 1
284： ' 各行の印刷
285： X = MLeft
286： objPic.CurrentX = X
287：
288：
289： ' ページの頭である場合にはヘッダ行を印刷する
290： If newPageFlag Then
291： ' ページの頭である場合
292： newPageFlag = False
293：
294： ' 横罫の印刷
295： X = objPic.CurrentX
296： Y = objPic.CurrentY
297： myLine objPic, X, Y, X + objPic.Width - MLeft - MRight, Y, drawFlag
298： objPic.CurrentX = X
299： objPic.CurrentY = Y
300：
301： If g_DGrid.ColumnHeaders Then
302： ' ヘッダ行を印刷する
303： ' ヘッダのフォントを設定
304： objPic.Font.Name = g_DGrid.HeadFont.Name
305： objPic.Font.Bold = g_DGrid.HeadFont.Bold
306： objPic.Font.Charset = g_DGrid.HeadFont.Charset
307： objPic.Font.Italic = g_DGrid.HeadFont.Italic
308： objPic.Font.Size = g_DGrid.HeadFont.Size
309： objPic.Font.Strikethrough = g_DGrid.HeadFont.Strikethrough
310： objPic.Font.Underline = g_DGrid.HeadFont.Underline
311：
312： ColMaxHeight = 0
313： X = objPic.CurrentX
314： ' ヘッダを印刷
315： For col = 0 To VisibleNum - 1
316： ' キャプションを印刷する
317： objPic.CurrentX = X
318： objPic.CurrentY = Y
319： ColHeight = DrawBox(objPic, g_DGrid.Columns(colIndex(col)).Caption, _
colWidth(col), g_DGrid.Columns(colIndex(col)).Alignment, drawFlag)
320： If ColHeight > ColMaxHeight Then
321： ColMaxHeight = ColHeight
322： End If
323： X = X + colWidth(col)
324： Next
325： ' 縦線を印刷
326： X = MLeft
327： For col = 0 To VisibleNum - 1
328： myLine objPic, X, Y, X, Y + ColMaxHeight, drawFlag
329： X = X + colWidth(col)
330： Next
331：
332： myLine objPic, X, Y, X, Y + ColMaxHeight, drawFlag
333：
334： ' 次の行に移動する
335： objPic.CurrentX = MLeft
336： objPic.CurrentY = Y + ColMaxHeight
337： End If
338： End If
339：
340： ' 横罫の印刷
341： X = objPic.CurrentX
342： Y = objPic.CurrentY
343： myLine objPic, X, Y, X + objPic.Width - MLeft - MRight, Y, drawFlag
344： objPic.CurrentX = X
345： objPic.CurrentY = Y
346：
347： ' 1行分のセルの中身を印刷する
348： X = objPic.CurrentX
349： ColMaxHeight = 0
350： ' フォントを設定
351： objPic.Font.Name = g_DGrid.Font.Name
352： objPic.Font.Bold = g_DGrid.Font.Bold
353： objPic.Font.Charset = g_DGrid.Font.Charset
354： objPic.Font.Italic = g_DGrid.Font.Italic
355： objPic.Font.Size = g_DGrid.Font.Size
356： objPic.Font.Strikethrough = g_DGrid.Font.Strikethrough
357： objPic.Font.Underline = g_DGrid.Font.Underline
358：
359： BookMark = g_DGrid.GetBookmark(row)
360： For col = 0 To VisibleNum - 1
361： ' 中身を印刷する
362： objPic.CurrentX = X
363： objPic.CurrentY = Y
364： ColHeight = DrawBox(objPic, g_DGrid.Columns(colIndex(col)).CellText(BookMark), _
colWidth(col), g_DGrid.Columns(colIndex(col)).Alignment, drawFlag)
365： If ColHeight > ColMaxHeight Then
366： ColMaxHeight = ColHeight
367： End If
368： X = X + colWidth(col)
369： Next
370：
371： ' 縦線を印刷
372： X = MLeft
373： For col = 0 To VisibleNum - 1
374： myLine objPic, X, Y, X, Y + ColMaxHeight, drawFlag
375： X = X + colWidth(col)
376： Next
377： myLine objPic, X, Y, X, Y + ColMaxHeight, drawFlag
378： 379： ' 1ページをはみ出していないかどうかを確認する
380： If objPic.CurrentY > objPic.Height - MDown - MUp Then
381： ' ページをはみ出しているので次のページに移動する
382：
383： ' このページで印刷が終わりかどうか
384： If NowPage >= EndPage Then
385： ' このページで印刷が終わりなのでループを抜ける
386： Exit For
387： End If
388：
389： ' 次のページに移動する
390：
391： ' 最後の横線の印刷
392： X = MLeft
393： objPic.CurrentX = X
394：
395： myLine objPic, X, objPic.CurrentY, _
X + objPic.Width, objPic.CurrentY, drawFlag
396： objPic.CurrentX = X
397： objPic.CurrentY = Y
398：
399： ' 次のページに移動する
400： If objPic Is Printer And drawFlag Then
401： ' プリンタの場合には改ページする
402： objPic.NewPage
403： End If
404：
405： NowPage = NowPage + 1
406： newPageFlag = True
407：
408： If (NowPage >= StartPage) And (NowPage <= EndPage) Then
409： ' 表示する
410： drawFlag = True
411： Else
412： ' 表示しない
413： drawFlag = False
414： End If
415：
416： objPic.CurrentX = MLeft
417： objPic.CurrentY = MUp
418： End If
419： Next
420：
421： ' ページの終わり
422： ' 横線の印刷
423： X = MLeft
424： objPic.CurrentX = X
425：
426： myLine objPic, X, objPic.CurrentY, _
X + objPic.Width - MLeft - MRight, objPic.CurrentY, drawFlag
427： objPic.CurrentX = X
428： objPic.CurrentY = Y
429：
430： If objPic Is Printer Then
431： ' プリンタの場合にはプリンタの終了処理をする
432： objPic.EndDoc
433： End If
434：
435： DrawPreview = NowPage
436：
437： If Not IsNull(oldBookMark) Then
438： ' 保存していた位置にカレント行を戻す
439： g_DGrid.BookMark = oldBookMark
440： End If
441：
442： Set objRec = Nothing
443：
444： Exit Function
445：
446： ErrHandle: 447： ' エラーハンドラ
448： If objPic Is Printer Then
449： ' プリンタの場合には中断処理をする
450： objPic.KillDoc
451： objPic.EndDoc
452： End If
453：
454： Set objRec = Nothing
455： DrawPreview = -1
456： MsgBox Err.Description, vbOKOnly, "印刷エラー"
457： End Function