Excel VBA質問箱 IV

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

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


38068 / 76732 ←次へ | 前へ→

【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

1 hits

【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 お礼

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