| |
一応、
(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
|
|
Blue
- 06/10/26(木) 10:16 -
