Excel VBA質問箱 IV

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

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


6678 / 13644 ツリー ←次へ | 前へ→

【43715】プリンター名の習得 hwata 06/10/23(月) 15:55 質問[未読]
【43716】Re:プリンター名の習得 Blue 06/10/23(月) 16:00 発言[未読]
【43802】Re:プリンター名の習得 hwata 06/10/26(木) 9:41 お礼[未読]
【43807】Re:プリンター名の習得 Blue 06/10/26(木) 10:16 発言[未読]
【43719】Re:プリンター名の習得 ichinose 06/10/23(月) 16:42 発言[未読]
【43800】Re:プリンター名の習得 hwata 06/10/26(木) 9:38 お礼[未読]
【43801】Re:プリンター名の習得 hwata 06/10/26(木) 9:38 お礼[未読]

【43715】プリンター名の習得
質問  hwata  - 06/10/23(月) 15:55 -

引用なし
パスワード
   パソコンに接続されているプリンター名を習得したいと思います

アクテブプリンターであれば Application.ActivePrinter を使えば表示できるのですが

そうでないプリンターに関しては
VBA質問箱で WSH を 教えていただき その中から EnumPrinterConnections を使い
  CreateObject("WScript.Network").EnumPrinterConnections.Count
     でプリンター接続件数を取得し
  CreateObject("WScript.Network").EnumPrinterConnections.Item(i + 1)
     でプリンター名を 取得しました

XP だと プリンター名の後に on neXX がつくと思います (例 LS-6800 on Ne02)
Application.ActivePrinter だと LS-6800 on Ne02 と取得できるのですが
CreateObject("WScript.Network").EnumPrinterConnections.Item(i + 1)
を使うと LS-6800 となり on Ne02 の部分が取得できません
WSHに関してホームページを検索してみたのですが 答えは見つかりません

WSHにはこだわっていません
プリンター名の収集について どなかか 教えていただけないでしょうか

【43716】Re:プリンター名の習得
発言  Blue  - 06/10/23(月) 16:00 -

引用なし
パスワード
   参考にどうぞ

http://park7.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200605/06050120.txt

【43719】Re:プリンター名の習得
発言  ichinose  - 06/10/23(月) 16:42 -

引用なし
パスワード
   ▼hwata さん:
こんばんは。

http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=18184;id=excel

過去ログです。

私は「shell.application」からアプローチしてみましたが、

shousukeさんのAPIも参考にしてみてください。

【43800】Re:プリンター名の習得
お礼  hwata  - 06/10/26(木) 9:38 -

引用なし
パスワード
   ▼ichinose さん お礼遅くなって申し訳けありません


両方実行してみました。

・「shell.application」
 98系では動いたのですが XPでは動きませんでした

・shousukeさんのAPI
 98系,XP系で動きました
 私の変更の仕方が悪かったのか 続けて行うと 前回の内容を持ってきてしまいました
  (1回目プリンター接続件数=3 ,2回目実行時のプリンター接続件数=5)
 通常は 1回のみ実効のため 問題ないかと思います

業務で使うマクロ作れそうです ありがとうございました

  ログが数件に分かれていて 不慣れな私には 分かりづらかったため 私の作った物を記載します

  Sub 接続プリンター表示_API()

   プリンタ名収集
 
   MsgBox "現在接続しているプリンター : " & Get_Printer_Idx + 1

   For i = 0 To Get_Printer_Idx Step 1
     MsgBox "現在接続しているプリンター : " & Get_Printer_Name(i) & " on " & Get_Printer_Port(i)
   Next
 
  End Sub


 Public Declare Function GetProfileString Lib "kernel32" Alias _
     "GetProfileStringA" (ByVal lpAppName As String, _
               ByVal lpKeyName As String, _
               ByVal lpDefault As String, _
               ByVal lpReturnedString As String, _
               ByVal nSize As Long) As Long
               
Public Get_Printer_Name(20) As String
Public Get_Printer_Port(20) As String
Public Get_Printer_Idx As Integer


Public Sub プリンタ名収集()


Dim vntArray As Variant, Element As Variant
Dim intCount As Integer, strPrinter As String, intPos As Integer, strPort As String

Get_PRINT_IDX = 0

'エントリ検索
vntArray = API_GetProfileString("Devices", vbNullString, "NotFound", 1024, Chr(0))

If IsEmpty(vntArray) = False Then

  For intCount = LBound(vntArray) To UBound(vntArray)
  
    'キー検索
    strPrinter = vntArray(intCount)                   'プリンタ名
    Element = API_GetProfileString("Devices", strPrinter, "NotFound", 1024, Chr(0))
  
    If IsEmpty(Element) = False Then
   
      intPos = InStr(1, Element(0), ",")
'区切り文字(,)位置
      If intPos <> 0 Then strPort = Mid(Element(0), intPos + 1, Len(Element(0)) - intPos)
   
        '====================
        'Debug.Print strPort & " on " & strPrinter
        '====================

      Get_Printer_Name(Get_Printer_Idx) = strPrinter
      Get_Printer_Port(Get_Printer_Idx) = strPort
      Get_Printer_Idx = Get_Printer_Idx + 1
      
     
      End If
 
   Next intCount
 
End If

Get_Printer_Idx = Get_Printer_Idx - 1

End Sub


'以下は関数***
Public Function API_GetProfileString(strAppName As String, strKeyName As String, strDefault As String, _
  lngSize As Long, strDelimiter As String) As Variant

Dim strBuf As String                              '情報を取得するためのバッファ
Dim lngResult As Long                              '戻り値
Dim lngStart As Long, lngPos As Long
Dim strTemp As String, strArray() As String, intCount As Integer

'On Error Resume Next

  '---------------------------------------------------------------------------
  '関数の呼び出し
  '---------------------------------------------------------------------------
  'WIN.INI からの情報を取得するためのバッファ
  strBuf = Space(lngSize)
 
  'WIN.INI から指定したエントリないでキーを検索、該当データのバイト数を返す
  lngResult = GetProfileString(strAppName, strKeyName, strDefault, strBuf, lngSize)
 
  '戻り値(テンポラリ)
  strTemp = Trim(Left(strBuf, lngResult))
 
  '---------------------------------------------------------------------------
  '戻り値チェック
  '---------------------------------------------------------------------------
  If strTemp = Empty Then API_GetProfileString = Empty: Exit Function     'キーなし時
  If strTemp = strDefault Then API_GetProfileString = Empty: Exit Function  '該当なし時
 
  lngStart = 1: intCount = Empty
 
  '**********
  '複数戻り値の場合のチェック
  Do
    lngPos = InStr(lngStart, strTemp, strDelimiter)             'データ区切り位置検出
  
    If lngPos = 0 And (lngStart > 1) Then Exit Do              'データ区切りなし時終了
  
    If Mid(strTemp, lngStart, 1) <> strDelimiter Then
   
      '区切られたデータを配列に格納
      ReDim Preserve strArray(intCount) As String
      If lngPos = 0 Then
        strArray(intCount) = strTemp
      Else
        strArray(intCount) = Mid(strTemp, lngStart, lngPos - lngStart)
      End If
  
    End If
  
    lngStart = lngPos + 1                          '検索開始位置
    intCount = intCount + 1                         '配列の要素インデックス増
  
  Loop Until lngPos = 0
  '**********
 
  '戻り値
  API_GetProfileString = strArray
 
End Function
 

【43801】Re:プリンター名の習得
お礼  hwata  - 06/10/26(木) 9:38 -

引用なし
パスワード
   ichinose さん お礼遅くなって申し訳けありません


両方実行してみました。

・「shell.application」
 98系では動いたのですが XPでは動きませんでした

・shousukeさんのAPI
 98系,XP系で動きました
 私の変更の仕方が悪かったのか 続けて行うと 前回の内容を持ってきてしまいました
  (1回目プリンター接続件数=3 ,2回目実行時のプリンター接続件数=5)
 通常は 1回のみ実効のため 問題ないかと思います

業務で使うマクロ作れそうです ありがとうございました

  ログが数件に分かれていて 不慣れな私には 分かりづらかったため 私の作った物を記載します

  Sub 接続プリンター表示_API()

   プリンタ名収集
 
   MsgBox "現在接続しているプリンター : " & Get_Printer_Idx + 1

   For i = 0 To Get_Printer_Idx Step 1
     MsgBox "現在接続しているプリンター : " & Get_Printer_Name(i) & " on " & Get_Printer_Port(i)
   Next
 
  End Sub


 Public Declare Function GetProfileString Lib "kernel32" Alias _
     "GetProfileStringA" (ByVal lpAppName As String, _
               ByVal lpKeyName As String, _
               ByVal lpDefault As String, _
               ByVal lpReturnedString As String, _
               ByVal nSize As Long) As Long
               
Public Get_Printer_Name(20) As String
Public Get_Printer_Port(20) As String
Public Get_Printer_Idx As Integer


Public Sub プリンタ名収集()


Dim vntArray As Variant, Element As Variant
Dim intCount As Integer, strPrinter As String, intPos As Integer, strPort As String

Get_PRINT_IDX = 0

'エントリ検索
vntArray = API_GetProfileString("Devices", vbNullString, "NotFound", 1024, Chr(0))

If IsEmpty(vntArray) = False Then

  For intCount = LBound(vntArray) To UBound(vntArray)
  
    'キー検索
    strPrinter = vntArray(intCount)                   'プリンタ名
    Element = API_GetProfileString("Devices", strPrinter, "NotFound", 1024, Chr(0))
  
    If IsEmpty(Element) = False Then
   
      intPos = InStr(1, Element(0), ",")
'区切り文字(,)位置
      If intPos <> 0 Then strPort = Mid(Element(0), intPos + 1, Len(Element(0)) - intPos)
   
        '====================
        'Debug.Print strPort & " on " & strPrinter
        '====================

      Get_Printer_Name(Get_Printer_Idx) = strPrinter
      Get_Printer_Port(Get_Printer_Idx) = strPort
      Get_Printer_Idx = Get_Printer_Idx + 1
      
     
      End If
 
   Next intCount
 
End If

Get_Printer_Idx = Get_Printer_Idx - 1

End Sub


'以下は関数***
Public Function API_GetProfileString(strAppName As String, strKeyName As String, strDefault As String, _
  lngSize As Long, strDelimiter As String) As Variant

Dim strBuf As String                              '情報を取得するためのバッファ
Dim lngResult As Long                              '戻り値
Dim lngStart As Long, lngPos As Long
Dim strTemp As String, strArray() As String, intCount As Integer

'On Error Resume Next

  '---------------------------------------------------------------------------
  '関数の呼び出し
  '---------------------------------------------------------------------------
  'WIN.INI からの情報を取得するためのバッファ
  strBuf = Space(lngSize)
 
  'WIN.INI から指定したエントリないでキーを検索、該当データのバイト数を返す
  lngResult = GetProfileString(strAppName, strKeyName, strDefault, strBuf, lngSize)
 
  '戻り値(テンポラリ)
  strTemp = Trim(Left(strBuf, lngResult))
 
  '---------------------------------------------------------------------------
  '戻り値チェック
  '---------------------------------------------------------------------------
  If strTemp = Empty Then API_GetProfileString = Empty: Exit Function     'キーなし時
  If strTemp = strDefault Then API_GetProfileString = Empty: Exit Function  '該当なし時
 
  lngStart = 1: intCount = Empty
 
  '**********
  '複数戻り値の場合のチェック
  Do
    lngPos = InStr(lngStart, strTemp, strDelimiter)             'データ区切り位置検出
  
    If lngPos = 0 And (lngStart > 1) Then Exit Do              'データ区切りなし時終了
  
    If Mid(strTemp, lngStart, 1) <> strDelimiter Then
   
      '区切られたデータを配列に格納
      ReDim Preserve strArray(intCount) As String
      If lngPos = 0 Then
        strArray(intCount) = strTemp
      Else
        strArray(intCount) = Mid(strTemp, lngStart, lngPos - lngStart)
      End If
  
    End If
  
    lngStart = lngPos + 1                          '検索開始位置
    intCount = intCount + 1                         '配列の要素インデックス増
  
  Loop Until lngPos = 0
  '**********
 
  '戻り値
  API_GetProfileString = strArray
 
End Function
 

【43802】Re:プリンター名の習得
お礼  hwata  - 06/10/26(木) 9:41 -

引用なし
パスワード
   Blue さんさん お礼遅くなって申し訳ありません

私の知識不足のため
記載されていたWEBアドレスの内容を理解するのに手間取っています
もう少し時間をかけて 使えるようにします

いずれにしても 回答ありがとうございました

【43807】Re:プリンター名の習得
発言  Blue  - 06/10/26(木) 10:16 -

引用なし
パスワード
   一応、
(DeclareのAPIが全て使える環境ならば)
どの環境でも動くように作ってあるんですけどね。


ごちゃごちゃしすぎてコードがわかりにくいのもあるのかな。
まとめたのを載せます。

Option Explicit

Private Type PRINTER_INFO_5
  pPrinterName As Long
  pPortName  As Long
  Attributes  As Long
  DeviceNotSelectedTimeout As Long
  TransmissionRetryTimeout As Long
End Type

Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" _
  (ByVal pPrinterName As String, ByRef phPrinter As Long, ByVal pDefault As Long) As Boolean
Private Declare Function ClosePrinter Lib "winspool.drv" _
  (ByVal hPrinter As Long) As Boolean
Private Declare Function GetPrinter Lib "winspool.drv" Alias "GetPrinterA" _
  (ByVal hPrinter As Long, ByVal Level As Long, ByRef pPrinter As Byte, ByVal cbBuf As Long, ByRef pcbNeeded As Long) As Boolean
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
  (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function GetProfileString Lib "kernel32.dll" Alias "GetProfileStringA" _
  (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long

' プリンタ指定文字列タイプ
Private Enum PrinterStrType
  PortNum_No_Name   ' (ポート番号) の (プリンタ名)
  PortName_No_Name  ' (ポート名) の (プリンタ名)
  Name_On_PortNum   ' (プリンタ名) on (ポート番号)
  Name_On_PortName  ' (プリンタ名) on (ポート名)
  Unknown       ' 不明
End Enum

' 実際に動かす関数
Sub test()
  Dim printerName As String
  
  ' 使いたいプリンタの名前を設定する
  printerName = "LS-6800 " ' ★★ここを編集する★★
  
  On Error Resume Next
  ' ActivePrinterに設定
  Application.ActivePrinter = GetPrinterStr(printerName)
  
  If Err.Number = 0 Then
    MsgBox "ActivePrinterを設定しました。" & vbCrLf & Application.ActivePrinter
  Else
    MsgBox printerName & " をActivePrinterに設定することは出来ませんでした。"
  End If
  On Error GoTo 0
End Sub

Private Function GetPrinterStr(ByVal strPrinterName) As String
  Select Case GetPrinterStrType
    Case PortNum_No_Name
      GetPrinterStr = GetPortNumStr(strPrinterName) & " の " & strPrinterName
    Case PortName_No_Name
      GetPrinterStr = GetPortName(strPrinterName) & " の " & strPrinterName
    Case Name_On_PortNum
      GetPrinterStr = strPrinterName & " on " & GetPortNumStr(strPrinterName)
    Case Name_On_PortName
      GetPrinterStr = strPrinterName & " on " & GetPortName(strPrinterName)
  End Select
End Function

' Application.ActivePrinterからプリンタ設定文字列を判定
Private Function GetPrinterStrType() As PrinterStrType
  Dim strActivePrinter As String
  Dim strName     As String
  Dim strPortNumStr  As String
  Dim pos As Long
  
  strActivePrinter = Application.ActivePrinter
  pos = InStr(strActivePrinter, " の ")
  If pos > 0 Then
    strName = Mid$(strActivePrinter, pos + 3)
    strPortNumStr = GetPortNumStr(strName)
    If Left$(strActivePrinter, pos - 1) = strPortNumStr Then
      ' (ポート番号) の (プリンタ名)
      GetPrinterStrType = PortNum_No_Name
    Else
      ' (ポート名) の (プリンタ名)
      GetPrinterStrType = PortName_No_Name
    End If
  Else
    pos = InStr(strActivePrinter, " on ")
    If pos > 0 Then
      strName = Left$(strActivePrinter, pos - 1)
      strPortNumStr = GetPortNumStr(strName)
      If Mid$(strActivePrinter, pos + 4) = strPortNumStr Then
        ' (プリンタ名) on (ポート番号)
        GetPrinterStrType = Name_On_PortNum
      Else
        ' (プリンタ名) on (ポート名)
        GetPrinterStrType = Name_On_PortName
      End If
    Else
      ' Unknown
      GetPrinterStrType = Unknown
    End If
  End If
End Function

Private Function GetPortName(ByVal strPrinterName As String) As String
  Dim hPrinter   As Long
  Dim bytPrinter() As Byte
  Dim lngNeed    As Long
  Dim tPrinterInfo As PRINTER_INFO_5
  Dim temp     As Byte
  Dim lngAddress  As Long
  Dim bytPortName() As Byte
  Dim lngLen    As Long

  If OpenPrinter(strPrinterName, hPrinter, 0&) Then
    GetPrinter hPrinter, 5, ByVal 0, 0, lngNeed
    ReDim bytPrinter(lngNeed)
    GetPrinter hPrinter, 5, bytPrinter(0), lngNeed, lngNeed
    CopyMemory tPrinterInfo, bytPrinter(0), Len(tPrinterInfo)

    lngAddress = tPrinterInfo.pPortName
    Do
      CopyMemory temp, ByVal lngAddress, 1
      If temp = 0 Then Exit Do
      ReDim Preserve bytPortName(lngLen)
      bytPortName(lngLen) = temp
      lngAddress = lngAddress + 1
      lngLen = lngLen + 1
    Loop

    ClosePrinter hPrinter
  End If
  If lngLen > 0 Then
    GetPortName = StrConv(bytPortName, vbUnicode)
  End If
End Function

Private Function GetPortNumStr(ByVal strPrinterName As String) As String
  Dim buff As String
  
  buff = String(256, vbNullChar)
  If GetProfileString("Devices", strPrinterName, "", buff, Len(buff)) Then
    GetPortNumStr = Left$(buff, InStr(buff, vbNullChar) - 1)
    GetPortNumStr = Mid$(GetPortNumStr, InStr(GetPortNumStr, ",") + 1)
  End If
End Function

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