Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


63139 / 76732 ←次へ | 前へ→

【18192】Re:プリンタコードの取得
発言  ichinose  - 04/9/17(金) 18:25 -

引用なし
パスワード
   IROC さん、kumaさん、こんばんは。

このサイトにAPIを使用した取得方法が掲載されていたはずなんですが、
V3まで探したけど、みつかりませんでした。
で、ちょっと遅いけど、こんな方法を試してみて下さい。

標準モジュール(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)では
うまく動いてくれました。

0 hits

【18184】プリンタコードの取得 kuma 04/9/17(金) 11:54 質問
【18186】Re:プリンタコードの取得 IROC 04/9/17(金) 14:14 回答
【18187】Re:プリンタコードの取得 kuma 04/9/17(金) 15:41 発言
【18188】Re:プリンタコードの取得 IROC 04/9/17(金) 16:32 回答
【18192】Re:プリンタコードの取得 ichinose 04/9/17(金) 18:25 発言
【18214】Re:プリンタコードの取得 訂正 ichinose 04/9/18(土) 13:25 発言
【18238】Re:プリンタ一覧の取得 shousuke 04/9/18(土) 23:55 発言
【18239】Re:プリンタ一覧の取得 shousuke 04/9/18(土) 23:58 発言
【18314】Re:プリンタ一覧の取得 kuma 04/9/21(火) 11:44 お礼
【18358】Re:プリンタ一覧の取得 ichinose 04/9/21(火) 22:11 発言
【18431】Re:プリンタ一覧の取得 shousuke 04/9/23(木) 18:27 お礼
【18585】Re:プリンタ一覧の取得 kuma 04/9/30(木) 12:15 お礼

63139 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free