| |
IROC さん、kumaさん、こんばんは。
このサイトにAPIを使用した取得方法が掲載されていたはずなんですが、
Ｖ３まで探したけど、みつかりませんでした。
で、ちょっと遅いけど、こんな方法を試してみて下さい。
標準モジュール（Module1）に
'================================================================
Sub プリンター取得()
'アクティブシートのセルA1からプリンタ名を設定する
Dim pr_name
If open_printer = True Then
idx = 1
pr_name = get_printer(True)
Do While pr_name <> ""
Cells(idx, 1).Value = pr_name
idx = idx + 1
pr_name = get_printer(False)
Loop
Call close_printer
End If
End Sub
別の標準モジュール（Module2）に
'====================================================================
'=======================================================
' プリンター名i/oプロシジャーパック
'=======================================================
Private fol
Private folds
Private pr_array() As String
Private pr_idx()
Private e_app As Application
Private job_pr, cur_pr
'=================================================================
Function open_printer() As Boolean
'プリンター名をpr_arrayに、FolderitemのIDをpr_idx()にセット
' output open_printer true 正常終了
' false 異常終了
On Error GoTo err_open_printer
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(Optional first As Boolean = False)
' プリンターを取り出す(dir関数に使い方が似てる?)
' input first : true 最初のプリンタ
' false 次のプリンタ
' output get_printer_name : プリンタ
On Error Resume Next
Static idx
If first = True Then
If e_app Is Nothing Then
e_app.Quit
Set e_app = Nothing
End If
Set e_app = CreateObject("excel.application")
job_pr = e_app.ActivePrinter
cur_pr = ActivePrinter
idx = 1
End If
get_printer = ""
If idx <= UBound(pr_array()) Then
nm = pr_array(idx)
Call set_used_printer(nm)
DoEvents
get_printer = e_app.ActivePrinter
idx = idx + 1
Else
Call set_used_printer(Trim(Split(job_pr, "on")(0)))
Application.Wait [now()] + TimeValue("00:00:01")
e_app.Quit
Set e_app = Nothing
ActivePrinter = cur_pr
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
If Not app Is Nothing Then
Call set_used_printer(Trim(Split(job_pr, "on")(0)))
Application.Wait [now()+1/864000]
e_app.Quit
Set e_app = Nothing
ActivePrinter = cur_pr
End If
Erase pr_array
Erase pr_idx
Set fol = Nothing
Set folds = Nothing
On Error GoTo 0
End Sub
確認してみて下さい。私の環境（Win98+Excel2000）では
うまく動いてくれました。
|
|
ichinose
- 04/9/17(金) 18:25 -
