List 7-58 PrintSetupプロシージャ
1： Public vPrintDlg As PRINTDLG
2： Public vDevMode As DEVMODE
3： Public vDevNames As DEVNAMES
4：
5： Public Function PrintSetup(ByVal Flags As Long, ByVal FormHwnd As Long) As Boolean
6： ' プリンタを設定する
7： ' ユーザーがプリンタの設定を変更したならばTrue，そうでなければFalseを返す
8： Dim pWidth As Long, pHeight As Long
9： Dim lpDevMode As Long, lpDevNames As Long
10： Dim hDevMode As Long, hDevNames As Long
11： Dim NewDriverName As String, NewDeviceName As String, NewPortName As String
12：
13： ' その時点のプリンタの情報をvDevModeに格納する
14：
15： ' 構造体の大きさを設定
16： vDevMode.dmSize = Len(vDevMode)
17： vDevMode.dmSpecVersion = 0
18： vDevMode.dmDriverVersion = 0
19： vDevMode.dmDriverExtra = 0
20： vDevMode.dmFields = 0
21：
22： ' 設定中にいくつかのエラーが出ることがあるので，
23： ' エラーをトラップするようにしておく
24： On Error Resume Next
25：
26： ' プリンタ名
27： vDevMode.dmDeviceName = Printer.DeviceName
28：
29： ' wDriverOffset，wDeviceOffset，wOutputOffset，wDefaultのサイズの和
30： vDevNames.wDriverOffset = 8
31： ' デフォルト名
32： vDevNames.wDefault = 0
33： ' デバイス名
34： vDevNames.wDeviceOffset = vDevNames.wDriverOffset + 1 + Len(Printer.DriverName)
35： ' ポート名
36： vDevNames.wOutputOffset = vDevNames.wDeviceOffset + 1 + Len(Printer.DeviceName)
37： ' 実際のデータ
38： vDevNames.extData = Printer.DriverName & Chr(0) & _
39： Printer.DeviceName & Chr(0) & Printer.Port & Chr(0)
40：
41： MsgBox Printer.DriverName
42： MsgBox Printer.DeviceName
43： MsgBox Printer.Port
44：
45： MsgBox vDevNames.wDriverOffset
46： MsgBox vDevNames.wDeviceOffset
47： MsgBox vDevNames.wOutputOffset
48：
49： ' 用紙
50： If Printer.PaperSize <> vbPRPSUser Then
51： ' 定型用紙
52： vDevMode.dmFields = vDevMode.dmFields Or DM_PAPERSIZE
53： vDevMode.dmPaperSize = Printer.PaperSize
54： vDevMode.dmPaperWidth = 0
55： vDevMode.dmPaperLength = 0
56： Else
57： ' 不定形用紙
58： vDevMode.dmFields = vDevMode.dmFields Or DM_PAPERSIZE Or _
DM_PAPERLENGTH Or DM_PAPERWIDTH
59： vDevMode.dmPaperSize = vbPRPSUser
60： vDevMode.dmPaperWidth = Printer.ScaleX(Printer.Width, _
Printer.ScaleMode, vbHimetric)
61： vDevMode.dmPaperLength = Printer.ScaleY(Printer.Height, _
Printer.ScaleMode, vbHimetric)
62： End If
63：
64： ' 給紙トレイ
65： vDevMode.dmDefaultSource = Printer.PaperBin
66： If Err.Number = 0 Then
67： vDevMode.dmFields = vDevMode.dmFields Or DM_DEFAULTSOURCE
68： Else
69： Err.Clear
70： End If
71：
72： ' 印字品質
73： vDevMode.dmPrintQuality = Printer.PrintQuality
74： If Err.Number = 0 Then
75： vDevMode.dmFields = vDevMode.dmFields Or DM_PRINTQUALITY
76： Else
77： Err.Clear
78： End If
79：
80： ' カラー
81： vDevMode.dmColor = Printer.ColorMode
82： If Err.Number = 0 Then
83： vDevMode.dmFields = vDevMode.dmFields Or DM_COLOR
84： Else
85： Err.Clear
86： End If
87：
88： ' 両面印刷
89： vDevMode.dmDuplex = Printer.Duplex
90： If Err.Number = 0 Then
91： vDevMode.dmFields = vDevMode.dmFields Or DM_DUPLEX
92： Else
93： Err.Clear
94： End If
95：
96： ' 用紙の向き
97： vDevMode.dmOrientation = Printer.Orientation
98： If Err.Number = 0 Then
99： vDevMode.dmFields = vDevMode.dmFields Or DM_ORIENTATION
100： Else
101： Err.Clear
102： End If
103：
104： ' 拡大率
105： vDevMode.dmScale = Printer.Zoom
106： If Err.Number = 0 Then
107： vDevMode.dmFields = vDevMode.dmFields Or DM_SCALE
108： Else
109： Err.Clear
110： End If
111：
112： ' エラーハンドラの解除
113： On Error GoTo 0
114：
115： ' vDevModeの内容をグローバルメモリに保存
116： hDevMode = GlobalAlloc(GHND, Len(vDevMode))
117： lpDevMode = GlobalLock(hDevMode)
118： CopyMemory ByVal lpDevMode, vDevMode, Len(vDevMode)
119： GlobalUnlock hDevMode
120：
121： ' vDevNamesの内容をグローバルメモリに保存
123： lpDevNames = GlobalLock(hDevNames)
124： CopyMemory ByVal lpDevNames, vDevNames, Len(vDevNames)
125： GlobalUnlock hDevNames
126：
127： ' vPrintDlgの内容を初期化する
128： vPrintDlg.lStructSize = Len(vPrintDlg)
129： vPrintDlg.hwndOwner = FormHwnd
130： vPrintDlg.hDevMode = hDevMode
131： vPrintDlg.hDevNames = hDevNames
132： vPrintDlg.Flags = Flags
133：
134： ' ［プリンタの設定］ダイアログボックスの表示
135： If PRINTDLG(vPrintDlg) <> 0 Then
136： ' ユーザーが［OK］ボタンを押した
137： ' hDevModeメンバの値をvDevModeにコピーする
138： If vPrintDlg.hDevMode <> 0 Then
139： lpDevMode = GlobalLock(vPrintDlg.hDevMode)
140： CopyMemory vDevMode, ByVal lpDevMode, Len(vDevMode)
141： GlobalUnlock lpDevMode
142： GlobalFree vPrintDlg.hDevMode
143： End If
144：
145： ' hDevNamesメンバの値をvDevNamesにコピーする
146： If vPrintDlg.hDevNames <> 0 Then
147： lpDevNames = GlobalLock(vPrintDlg.hDevNames)
148： CopyMemory vDevNames, ByVal lpDevNames, Len(vDevNames)
149： GlobalUnlock lpDevNames
150： GlobalFree vPrintDlg.hDevNames
151： End If
152：
153： ' プリンタの設定値を変更する
154： Dim prt As Printer
155：
156： ' 新しく設定されたプリンタ名を取得する
157：
158： ' ドライバ名の取得
159： NewDriverName = Mid(vDevNames.extData, vDevNames.wDriverOffset - 8 + 1)
160： NewDriverName = Left(NewDriverName, InStr(NewDriverName, Chr(0)) - 1)
161： ' デバイス名の取得
162： NewDeviceName = Mid(vDevNames.extData, vDevNames.wDeviceOffset - 8 + 1)
163： NewDeviceName = Left(NewDeviceName, InStr(NewDeviceName, Chr(0)) - 1)
164： ' ポート名の取得
165： NewPortName = Mid(vDevNames.extData, vDevNames.wOutputOffset - 8 + 1)
166： NewPortName = Left(NewPortName, InStr(NewPortName, Chr(0)) - 1)
167：
168： ' 同じ設定を持つプリンタを探し，
169： ' それをデフォルトプリンタとする
170： For Each prt In Printers
171： If UCase(prt.DeviceName) = UCase(NewDeviceName) Then
172： ' このプリンタをデフォルトプリンタとする
173： Set Printer = prt
174： Exit For
175： End If
176： Next
177：
178： On Error Resume Next
179：
180： ' プリンタの用紙を設定する
181： If vDevMode.dmPaperSize <> vbPRPSUser Then
182： ' 定型用紙である
183： Printer.PaperSize = vDevMode.dmPaperSize
184： Else
185： ' 不定形用紙である
186： Printer.PaperSize = vbPRPSUser
187： Printer.Width = Printer.ScaleX(vDevMode.dmPaperWidth, _
vbHimetric, Printer.ScaleMode)
188： Printer.Height = Printer.ScaleY(vDevMode.dmPaperLength, _
vbHimetric, Printer.ScaleMode)
189： End If
190：
191： If Err.Number <> 0 Then
192： MsgBox "指定された用紙サイズが不正です", vbOKOnly, "プリンタの設定"
193： Err.Clear
194： End If
195：
196： ' 給紙トレイ
197： Printer.PaperBin = vDevMode.dmDefaultSource
198：
199： ' 印字品質
200： Printer.PrintQuality = vDevMode.dmPrintQuality
201：
202： ' カラー
203： Printer.ColorMode = vDevMode.dmColor
204：
205： ' 両面印刷
206： Printer.Duplex = vDevMode.dmDuplex
207：
208： ' 用紙の向き
209： Printer.Orientation = vDevMode.dmOrientation
210：
211： ' 拡大率
212： Printer.Zoom = vDevMode.dmScale
213：
214： PrintSetup = True
215： Else
216： ' キャンセルされた
217： PrintSetup = False
218： End If
219： End Function