| |
▼kohji さん：
こんばんは。
>VBAのコードから通常使用するプリンタのチェックを変更したいのですが
>どうすればいいのか教えてください
これって、ウインドウズの「スタート」----「設定」---「プリンタ」の中の
プリンタを「通常使用するプリンタ」にすると言う意味ですね？
標準モジュールのModule1に以下のコードを記述して下さい。
'=======================================================
' プリンター名i/oプロシジャーパック
'=======================================================
Dim folds
Dim pr_array() As String
Dim pr_idx()
'=======================================================
Function open_printer() As Boolean
'プリンター名をpr_arrayに、FolderitemのIDをpr_idx()にセット
' output open_printer true 正常終了
' false 異常終了
On Error Resume Next
Dim myshell
open_printer = True
Erase pr_array
Erase pr_idx
Set myshell = CreateObject("shell.application")
Set fol = myshell.NameSpace(4)
Set folds = fol.items
idx = 0: jdx = 1
Do While idx <= folds.Count - 1
Set fold = folds.Item(idx)
If Not fold.Name Like "プリンタ*" Then
ReDim Preserve pr_array(1 To jdx)
pr_array(jdx) = fold.Name
ReDim Preserve pr_idx(1 To jdx)
pr_idx(jdx) = idx
jdx = jdx + 1
End If
idx = idx + 1
Loop
ret_open_printer:
Set myshell = Nothing
On Error GoTo 0
Exit Function
err_open_printer:
MsgBox Error$(Err.Number)
open_printer = False
Resume ret_open_printer
End Function
'===========================================================
Function get_printer_name(Optional first As Boolean = False)
' プリンター名を取り出す(dir関数に使い方が似てる?)
' input first : true 最初のプリンタ名
' false 次のプリンタ名
' output get_printer_name : プリンタ名
On Error Resume Next
Static idx
If first = True Then
idx = 1
End If
get_printer_name = ""
If idx <= UBound(pr_array()) Then
get_printer_name = pr_array(idx)
idx = idx + 1
End If
On Error GoTo 0
End Function
'==========================================================
Function set_used_printer(pr_nm) As Long
'指定されたプリンタ名に該当するプリンタを通常使うプリンタに設定
'input pr_nm : プリンタ名
'output set_used_printer 0:正常 その他:失敗
On Error Resume Next
Dim id
id = WorksheetFunction.Match(pr_nm, pr_array(), 0)
If Err.Number = 0 Then
set_used_printer = 0
folds.Item(pr_idx(id)).InvokeVerb "通常使うプリンタに設定(&F)"
If Err.Number <> 0 Then
set_used_printer = Err.Number
End If
Else
set_used_printer = 1
End If
On Error GoTo 0
End Function
'============================================
Sub close_printer()
'プリンタ名i/oの終了
On Error Resume Next
Erase pr_array
Erase pr_idx
Set folds = Nothing
On Error GoTo 0
End Sub
次に標準モジュールのModule2に以下のコードを記述して下さい。
'=======================================================
Sub test()
Dim pr_name
If open_printer = True Then
pr_name = get_printer_name(True)
Do While pr_name <> ""
ans = MsgBox(pr_name & " を通常使うプリンタにしますか", vbYesNo)
If ans = vbYes Then
If set_used_printer(pr_name) <> 0 Then
MsgBox "設定失敗"
End If
Exit Do
End If
pr_name = get_printer_name()
Loop
Call close_printer
End If
End Sub
これで、プロシジャーtestを実行してみて下さい。
「test」は、
Msgboxでプリンタ名が表示されます。
「はい」で通常のプリンタに設定、「いいえ」で次のプリンタ名表示というコードです。
ちょっと不安なところもありますが、私の環境では動いてくれました。
Win98+Excel2000
|
|
- 03/9/11(木) 17:30 -
