Excel VBA プリンタを選択して印刷 （未実験）

Excel VBA質問箱 IV - 過去ログ
使ってみていないので、どんな感じかも分からないが、一応取っておく。

'**標準モジュール*******************************************:
' http://www.vbalab.net/vbaqa/data/excel/log/tree_796.htm
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
'【関数名】 GetProfileString
'【機能】 WIN.INIから指定されたエントリの文字列を取得する
'【引数】
' lpAppName: String－エントリを検索するセクション
' lpKeyName: String－検索するキー名またはエントリ
' lpDefault: String－指定されたエントリが見つからなかった時に返される規定値
' lpReturnedString:
' String－nSizeバイトを割り当てる文字列バッファ
' nSize: Long－lpReturnedStringに格納できる最大文字数
'【戻り値】 lpReturnedStringバッファにコピーされたバイト数（最後のNull文字は含まれない）
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━

'■ GetProfileString API関数（WIN.INIから指定されたエントリの文字列を取得する）
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

'==================================================================================================
'プリンタ名一覧を取得する関数
'戻り値：登録されているプリンタの数
'arg_vntPrinter():プリンタ名一覧（配列）
'arg_vntPort()：ポート名一覧（配列）
'arg_strErr:エラーメッセージ
Public Function pb_fncGetPrinter(ByRef arg_vntPrinter() As Variant, _
ByRef arg_vntPort() As Variant, ByRef arg_strErr As String) As Long

Const STR_APPNAME As String = "Devices" '目的のキーが所属しているセクションの名前（lpAppName）
Const STR_DEFAULT As String = "見つかりませんでした" '規定の文字列(lpDefault)
Const LNG_SIZE As Long = 1024 '情報を格納するバッファのサイズ(nSize)
Const STR_KEYNAME As String = vbNullString 'セクション内の全てのキーを取得(NULLを指定)

Dim lngRet As Long 'GetProfileString関数の戻り値
Dim strReturnedString As String * 1024
Dim strTmp As String
Dim lngNull As Long
Dim i As Long
Dim lngStart As Long
Dim strErr As String

On Error GoTo ErrHandler

'-Start---------------------------------------------------------
'プリンタ一覧を取得

'指定したセクション名を検索、セクションの全キーを取得、該当データのバイト数を返す
'バッファ（strReturnedString）に格納された文字数が返る
lngRet = GetProfileString(STR_APPNAME, STR_KEYNAME, STR_DEFAULT, strReturnedString, LNG_SIZE)

'最後のNULLを除く
strTmp = Left(strReturnedString, InStr(1, strReturnedString, Chr(0) & Chr(0)) - 1)

'戻り値チェック
If strTmp = STR_DEFAULT Then
strErr = "プリンター名が取得できませんでした"
GoTo ErrHandler
End If

lngNull = 0
i = 0
lngStart = 0

Do
i = i + 1
lngNull = InStr(lngNull + 1, strTmp, Chr(0))
If lngNull = 0 Then lngNull = Len(strTmp)
ReDim Preserve arg_vntPrinter(1 To i)
arg_vntPrinter(i) = Mid(strTmp, lngStart + 1, lngNull - lngStart)
If Right(arg_vntPrinter(i), 1) = Chr(0) Then '末尾のNULLを削除
arg_vntPrinter(i) = Left(arg_vntPrinter(i), Len(arg_vntPrinter(i)) - 1)
End If
lngStart = lngNull
Loop Until lngNull = Len(strTmp)
'-End-----------------------------------------------------------

pb_fncGetPrinter = i
ReDim arg_vntPort(1 To i)

'-Start---------------------------------------------------------
'ポート一覧を取得
For i = 1 To pb_fncGetPrinter

lngRet = GetProfileString(STR_APPNAME, arg_vntPrinter(i), STR_DEFAULT, strReturnedString, LNG_SIZE)

'最後のNULLを除く
strTmp = Left(strReturnedString, InStr(1, strReturnedString, Chr(0)) - 1)
strTmp = Mid(strTmp, InStr(1, strTmp, ",") + 1)

'戻り値チェック
If strTmp = STR_DEFAULT Then
strErr = "ポート名が取得できませんでした"
GoTo ErrHandler
Else
arg_vntPort(i) = strTmp
End If

Next i
'-End-----------------------------------------------------------

Exit Function

ErrHandler:
arg_strErr = strErr & vbCrLf & _
"フォームを閉じて終了させてください。" & _
vbCrLf & vbCrLf & Err.Number & " : " & Err.Description
pb_fncGetPrinter = 0

End Function

'**フォーム*******************************************:
Private pr_strPrinterArray() As String 'プリンター＆ポートのフルネーム

'==================================================================================================
Private Sub CommandButton1_Click()

With ListBox1
If .ListIndex = -1 Then
MsgBox "なにも選択されていません"
Else
MsgBox "選択されているプリンターは" & pr_strPrinterArray(.ListIndex + 1) & " です"
End If

End With

End Sub

'==================================================================================================
Private Sub UserForm_Initialize()

Dim strErrMsg As String
Dim vntPrinter() As Variant 'プリンター名（配列）
Dim vntPort() As Variant 'ポート名（配列）
Dim lngPrinterCount As Long 'pb_fncGetPrinerの戻り値（登録されているプリンター数）
Dim strActivePrinter As String
Dim i As Long

On Error GoTo ErrHandler

'-Start---------------------------------------------------------
'プリンター名、ポート名の設定
lngPrinterCount = pb_fncGetPrinter(vntPrinter(), vntPort(), strErrMsg)
If lngPrinterCount = 0 Then Resume ErrHandler

ReDim pr_strPrinterArray(1 To lngPrinterCount)

strActivePrinter = Application.ActivePrinter

If strActivePrinter Like "* on *" = True Then
strActivePrinter = Trim(Left(strActivePrinter, InStr(strActivePrinter, " on ") - 1))
For i = 1 To lngPrinterCount
pr_strPrinterArray(i) = vntPrinter(i) & " on " & vntPort(i)
Next
ElseIf strActivePrinter Like "* の *" = True Then
strActivePrinter = Trim(Mid(strActivePrinter, InStr(strActivePrinter, " の ") + 3))
For i = 1 To lngPrinterCount
pr_strPrinterArray(i) = vntPort(i) & " の " & vntPrinter(i)
Next
End If

With ListBox1
For i = 1 To lngPrinterCount
.AddItem vntPrinter(i)
Next i
End With
'-End----------------------------------------------------------

Exit Sub

ErrHandler:
If Len(strErrMsg) = 0 Then
strErrMsg = "フォームの表示段階でエラーが発生しました" & vbCrLf & _
"フォームを閉じて終了させてください。" & vbCrLf & vbCrLf & _
Err.Number & " : " & Err.Description
End If
MsgBox strErrMsg, vbCritical

End Sub