List 7-51 修正したFormPrintPreviewフォームのDrawPreviewプロシージャ（修正個所は赤色で示した）
1： Private Function DrawPreview(ByRef objPic As Object, _
ByRef StartPage As Long, _
ByRef EndPage As Long) As Long
2： ' プレビュー画面を描画する
3： ' 【引数】
4： ' objDoc = 描画対象となるオブジェクト
5： ' ピクチャボックスかPrinterオブジェクトのいずれか
6： ' StartPage = 先頭ページ番号
7： ' EndPage = 最終ページ番号
8： ' 【戻り値】
9： ' -1 = エラー
10： ' 正の数 = 出力した最終ページ番号
11： Dim row As Long, col As Long, i As Long
12： Dim objRec As ADODB.Recordset
13： Dim newPageFlag As Boolean
14： Dim columnNum As Long
15： Dim colWidth() As Long
16： Dim colIndex() As Long
17： Dim VisibleNum As Long
18： Dim X As Long, Y As Long
19： Dim MLeft As Long, MRight As Long, MUp As Long, MDown As Long
20： Dim ColWidthTotal As Long
21： Dim ColHeight As Long, ColMaxHeight As Long
22： Dim NowPage As Long
23： Dim BookMark As Variant, oldBookMark As Variant
24： Dim drawFlag As Boolean
25：
26： ' 余白情報の取得
27： If Not IsNumeric(TXT_UP.Text) Then
28： MsgBox "上余白が不正です", vbOKOnly, "印刷エラー"
29： DrawPreview = -1
30： Exit Function
31： Else
32： MUp = CLng(TXT_UP.Text)
33： End If
34：
35： If Not IsNumeric(TXT_DOWN.Text) Then
36： MsgBox "下余白が不正です", vbOKOnly, "印刷エラー"
37： DrawPreview = -1
38： Exit Function
39： Else
40： MDown = CLng(TXT_DOWN.Text)
41： End If
42：
43： If Not IsNumeric(TXT_LEFT.Text) Then
44： MsgBox "左余白が不正です", vbOKOnly, "印刷エラー"
45： DrawPreview = -1
46： Exit Function
47： Else
48： MLeft = CLng(TXT_LEFT.Text)
49： End If
50：
51： If Not IsNumeric(TXT_RIGHT.Text) Then
52： MsgBox "右余白が不正です", vbOKOnly, "印刷エラー"
53： DrawPreview = -1
54： Exit Function
55： Else
56： MRight = CLng(TXT_RIGHT.Text)
57： End If
58：
59： On Error GoTo ErrHandle
60：
61： ' 余白をmm単位からTwip単位に変換する
62： MUp = objPic.ScaleY(MUp,vbMillimeters, vbTwips)
63： MDown = objPic.ScaleY(MDown, vbMillimeters, vbTwips)
64： MLeft = objPic.ScaleX(MLeft, vbMillimeters, vbTwips)
65： MRight = objPic.ScaleX(MRight, vbMillimeters, vbTwips)
66：
67： Set objRec = g_DGrid.DataSource
68：
69： newPageFlag = True
70： NowPage = 1
71：
72： If (NowPage >= StartPage) And (NowPage <= EndPage) Then
73： ' 表示する
74： drawFlag = True
75： Else
76： ' 表示しない
77： drawFlag = False
78： End If
79：
80： ' DataGridコントロールの列数を取得
81： columnNum = g_DGrid.Columns.Count
82：
83： ' 列の幅を算出する
84： ' 用紙の横幅に合わせた形に表を引き延ばし，
85： ' もとのDataGridの列幅と比例する形で
86： ' 各列を分配する形で幅を求める
87： ' ただし，このとき，非表示の列は除く
88：
89： ReDim colWidth(columnNum)
90： ReDim colIndex(columnNum)
91：
92： ColWidthTotal = 0
93： VisibleNum = 0
94：
95： ' 各列の幅と，各列の幅の総和を求める
96： ' また，表示されている列の列番号（Columnオブジェクトのインデックス番号）を
97： ' colIndex配列に格納しておく
98： For i = 0 To columnNum - 1
99： If g_DGrid.Columns(i).Visible Then
100： ' 表示されているとき
101： colWidth(VisibleNum) = g_DGrid.Columns(i).Width
102： ColWidthTotal = ColWidthTotal + g_DGrid.Columns(i).Width
103： colIndex(VisibleNum) = i
104： VisibleNum = VisibleNum + 1
105： End If
106： Next
107：
108： ' 各列の幅が合うように揃える
109： For i = 0 To VisibleNum - 1
110： colWidth(i) = colWidth(i) * (objPic.Width - MLeft - MRight) * / ColWidthTotal
111： Next
112：
113： ' ページの印刷を開始
114：
115： ' カレント座標を左上の余白内位置に移動する
116： objPic.CurrentX = MLeft
117： objPic.CurrentY = MUp
118：
119： ' タイトルの印刷
120： If NowPage = 1 Then
121： ' 先頭ぺージであれば，タイトルを表示する
122： Dim oldFont As Font
123： Set oldFont = objPic.Font
124： Set objPic.Font = New StdFont
125： myPrint objPic, g_Title, drawFlag
126： myPrint objPic, "", drawFlag
127： myPrint objPic, "", drawFlag
128： Set objPic.Font = objPic.Font
129： End If
130：
131： ' 行を次々と表示する
132： Y = objPic.CurrentY
133：
134： ' その時点のブックマーク位置を保存しておく
135： oldBookMark = g_DGrid.BookMark
136：
137： ' レコードを先頭に移動する
138： objRec.MoveFirst
139：
140： ' レコード数だけループして各列を描画する
141： For row = 0 To objRec.RecordCount - 1
142： ' 各行の印刷
143： X = MLeft
144： objPic.CurrentX = X
145：
146：
147： ' ページの頭である場合にはヘッダ行を印刷する
148： If newPageFlag Then
149： ' ページの頭である場合
150： newPageFlag = False
151：
152： ' 横罫の印刷
153： X = objPic.CurrentX
154： Y = objPic.CurrentY
155： myLine objPic, X, Y, X + objPic.Width - MLeft - MRight, Y, drawFlag
156： objPic.CurrentX = X
157： objPic.CurrentY = Y
158：
159： If g_DGrid.ColumnHeaders Then
160： ' ヘッダ行を印刷する
161： ' ヘッダのフォントを設定
162： objPic.Font.Name = g_DGrid.HeadFont.Name
163： objPic.Font.Bold = g_DGrid.HeadFont.Bold
164： objPic.Font.Charset = g_DGrid.HeadFont.Charset
165： objPic.Font.Italic = g_DGrid.HeadFont.Italic
166： objPic.Font.Size = g_DGrid.HeadFont.Size
167： objPic.Font.Strikethrough = g_DGrid.HeadFont.Strikethrough
168： objPic.Font.Underline = g_DGrid.HeadFont.Underline
169：
170： ColMaxHeight = 0
171： X = objPic.CurrentX
172： ' ヘッダを印刷
173： For col = 0 To VisibleNum - 1
174： ' キャプションを印刷する
175： objPic.CurrentX = X
176： objPic.CurrentY = Y
177： ColHeight = DrawBox(objPic, g_DGrid.Columns(colIndex(col)).Caption, _
colWidth(col), g_DGrid.Columns(colIndex(col)).Alignment, drawFlag)
178： If ColHeight > ColMaxHeight Then
179： ColMaxHeight = ColHeight
180： End If
181： X = X + colWidth(col)
182： Next
183： ' 縦線を印刷
184： X = MLeft
185： For col = 0 To VisibleNum - 1
186： myLine objPic, X, Y, X, Y + ColMaxHeight, drawFlag
187： X = X + colWidth(col)
188： Next
189：
190： myLine objPic, X, Y, X, Y + ColMaxHeight, drawFlag
191：
192： ' 次の行に移動する
193： objPic.CurrentX = MLeft
194： objPic.CurrentY = Y + ColMaxHeight
195： End If
196： End If
197：
198： ' 横罫の印刷
199： X = objPic.CurrentX
200： Y = objPic.CurrentY
201： myLine objPic, X, Y, X + objPic.Width - MLeft - MRight, Y, drawFlag
202： objPic.CurrentX = X
203： objPic.CurrentY = Y
204：
205： ' 1行分のセルの中身を印刷する
206： X = objPic.CurrentX
207： ColMaxHeight = 0
208： ' フォントを設定
209： objPic.Font.Name = g_DGrid.Font.Name
210： objPic.Font.Bold = g_DGrid.Font.Bold
211： objPic.Font.Charset = g_DGrid.Font.Charset
212： objPic.Font.Italic = g_DGrid.Font.Italic
213： objPic.Font.Size = g_DGrid.Font.Size
214： objPic.Font.Strikethrough = g_DGrid.Font.Strikethrough
215： objPic.Font.Underline = g_DGrid.Font.Underline
216：
217： BookMark = g_DGrid.GetBookmark(row)
218： For col = 0 To VisibleNum - 1
219： ' 中身を印刷する
220： objPic.CurrentX = X
221： objPic.CurrentY = Y
222： ColHeight = DrawBox(objPic, g_DGrid.Columns(colIndex(col)).CellText(BookMark), _
colWidth(col), g_DGrid.Columns(colIndex(col)).Alignment, drawFlag)
223： If ColHeight > ColMaxHeight Then
224： ColMaxHeight = ColHeight
225： End If
226： X = X + colWidth(col)
227： Next
228：
229： ' 縦線を印刷
230： X = MLeft
231： For col = 0 To VisibleNum - 1
232： myLine objPic, X, Y, X, Y + ColMaxHeight, drawFlag
233： X = X + colWidth(col)
234： Next
235： myLine objPic, X, Y, X, Y + ColMaxHeight, drawFlag
236：
237： ' 1ページをはみ出ていないかどうかを確認する
238： If objPic.CurrentY > objPic.Height - MDown - MUp Then
239： ' ページをはみ出しているので次のページに移動する
240：
241： ' このページで印刷が終わりかどうか
242： If NowPage >= EndPage Then
243： ' このページで印刷が終わりなのでループを抜ける
244： Exit For
245： End If
246：
247： ' 次のページに移動する
248：
249： ' 最後の横線の印刷
250： X = MLeft
251： objPic.CurrentX = X
252：
253： myLine objPic, X, objPic.CurrentY, _
X + objPic.Width, objPic.CurrentY, drawFlag
254： objPic.CurrentX = X
255： objPic.CurrentY = Y
256：
257： ' 次のページに移動する
258： If objPic Is Printer And drawFlag Then
259： ' プリンタの場合には改ページする
260： objPic.NewPage
261： End If
262：
263： NowPage = NowPage + 1
264： newPageFlag = True
265：
266： If (NowPage >= StartPage) And (NowPage <= EndPage) Then
267： ' 表示する
268： drawFlag = True
269： Else
270： ' 表示しない
271： drawFlag = False
272： End If
273：
274： objPic.CurrentX = MLeft
275： objPic.CurrentY = MUp
276： End If
277： ' 中断処理になっていないかどうかをチェック
278： If objPic Is Printer Then
279 DoEvents
280： If FormPrinting.bCancelFlag Then
281： ' キャンセル処理
282： objPic.KillDoc
283： MsgBox "印刷が中断されました", vbOKOnly, "印刷"
284： Exit For
285： End If
286： End If
287：
288： Next
289：
290： ' ページの終わり
291： ' 横線の印刷
292： X = MLeft
293： objPic.CurrentX = X
294：
295： myLine objPic, X, objPic.CurrentY, _
X + objPic.Width - MLeft - MRight, objPic.CurrentY, drawFlag
296： objPic.CurrentX = X
297： objPic.CurrentY = Y
298：
299： If objPic Is Printer Then
300： ' プリンタの場合にはプリンタの終了処理をする
301： objPic.EndDoc
302： End If
303：
304： DrawPreview = NowPage
305：
306： If Not IsNull(oldBookMark) Then
307： ' 保存していた位置にカレント行を戻す
308： g_DGrid.BookMark = oldBookMark
309： End If
310：
311： Set objRec = Nothing
312：
313： Exit Function
314：
315： ErrHandle:
316： ' エラーハンドラ
317： If objPic Is Printer Then
318： ' プリンタの場合には中断処理をする
319： objPic.KillDoc
320： objPic.EndDoc
321： End If
322：
323： Set objRec = Nothing
324： DrawPreview = -1
325： MsgBox Err.Description, vbOKOnly, "印刷エラー"
326： End Function