| |
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, job_prnm, cur_pr
Private gpflg As Boolean
'============================================================
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 e_app = Nothing
Set myshell = CreateObject("shell.application")
Set fol = myshell.NameSpace(4)
Set folds = fol.items
gpflg = False
idx = 0: jdx = 1
Do While idx <= folds.Count - 1
Set fold = folds.Item(idx)
If IsNumeric(fol.GetDetailsOf(fold, 1)) 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
Set e_app = CreateObject("excel.application")
job_pr = e_app.ActivePrinter
e_app.Quit
Set e_app = Nothing
For idx = 1 To UBound(pr_array())
ans = InStr(job_pr, pr_array(idx))
If ans > 0 Then
job_prnm = pr_array(idx)
Exit For
End If
Next
cur_pr = ActivePrinter
ActivePrinter = job_pr
gpflg = True
idx = 1
End If
get_printer = ""
If idx <= UBound(pr_array()) Then
nm = pr_array(idx)
Call set_used_printer(nm)
If idx = 1 Then Call set_used_printer(nm)
Do Until ActivePrinter Like "*" & nm & "*"
DoEvents
Loop
get_printer = ActivePrinter
idx = idx + 1
Else
ActivePrinter = cur_pr
Call set_used_printer(job_prnm)
Do Until ActivePrinter = job_pr
DoEvents
Loop
ActivePrinter = cur_pr
gpflg = False
End If
On Error GoTo 0
End Function
'============================================================
Function get_printer_job_count(pr_nm)
'指定されたプリンタ名に該当するプリンタのジョブ数を取得する
'input pr_nm : プリンタ名
'output get_printer_job_count 数値:正常ジョブ数 false:失敗
On Error Resume Next
Dim id
id = WorksheetFunction.Match(pr_nm, pr_array(), 0)
If Err.Number = 0 Then
get_printer_job_count = fol.GetDetailsOf(folds.Item(pr_idx(id)), 1)
If Err.Number <> 0 Then
get_printer_job_count = False
End If
Else
get_printer_job_count = False
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 gpflg = True Then
ActivePrinter = cur_pr
Call set_used_printer(job_prnm)
Do Until ActivePrinter = job_pr
DoEvents
Loop
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/18(土) 13:25 -
