アクティブなプリンターでサポートされている用紙名

質問

http://support.microsoft.com/kb/229718/ja で「アクティブなプリンターでサポートされている用紙名の一覧を取得するマクロ」を見つけたので自分の環境で実行してみました。

ＯＳ：Windows　ＸＰ　ＳＰ３
アプリケーション：　エクセル2002（SP3）

結果はメッセージボックスが表示されるのですが、用紙名のリストが数文字ずつ少なり、リストの最後は「　）　」の一文字だけになります。またプリンタードライバーがリストする用紙の種類よりも少なくなっています。文字数がなくなったのだと思いますが・・・・・

active printerを取得→そのプリンタードライバを開く→ドライバーが持っている用紙の数を取得→Ｆｏｒ～Ｎｅｘｔでテキストに追加→メッセージボックスで表示しているだろうことはわかるのですが、得られる結果（用紙名の文字数が減少する）がわかりません。
どこをどのように直せば用紙名（できれば「サイズ」「用紙名の番号」も)取得できるでしょうか？
さらに言えば、メッセージボックスでなくワークシートのセルに書き出したいです。

お知恵をお貸しください。

該当のコードは以下のとおりです。

Option Explicit

Private Declare Function OpenPrinter Lib "winspool.drv" Alias _
"OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
ByVal pDefault As Long) As Long
Private Declare Function ClosePrinter Lib "winspool.drv" ( _
ByVal hPrinter As Long) As Long
Private Declare Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" (ByVal lpsDeviceName As String, _
ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
ByVal dev As Long) As Long

Private Const DC_PAPERNAMES = 16 ' Value obtained from wingdi.h

Sub GetPaperList()
' Display a message box with the name of the active printer and a list
' of papers it supports.

Dim lPaperCount As Long
Dim lCounter As Long
Dim hPrinter As Long
Dim sDeviceName As String
Dim sDevicePort As String
Dim sPaperNamesList As String
Dim sNextString As String
Dim sTextString As String
Dim iNumPaper() As Integer

GetPrinterNameAndPort sDeviceName, sDevicePort

If OpenPrinter(sDeviceName, hPrinter, 0) <> 0 Then

' Get count of paper names supported by active printer.
lPaperCount = DeviceCapabilities(sDeviceName, _
sDevicePort, _
DC_PAPERNAMES, _
ByVal vbNullString, 0)
ReDim iNumPaper(1 To lPaperCount)
sPaperNamesList = String(64 * lPaperCount, 0)

' Get paper names supported by active printer.
lPaperCount = DeviceCapabilities(sDeviceName, _
sDevicePort, _
DC_PAPERNAMES, _
ByVal sPaperNamesList, 0)

' List available paper names.
sTextString = "Paper available for " & ActivePrinter
For lCounter = 1 To lPaperCount

' Get a paper name.
sNextString = Mid(sPaperNamesList, _
64 * (lCounter - 1) + 1, 64)
sNextString = Left(sNextString, _
InStr(1, sNextString, Chr(0)) - 1)

' Have one paper name.
sNextString = String(6 - Len(CStr(iNumPaper(lCounter))), _
" ") & sNextString

' Add paper name to text string for message box.
sTextString = sTextString & Chr(13) & sNextString

Next lCounter

ClosePrinter (hPrinter)

' Show paper names in message box.
MsgBox sTextString

Else
MsgBox ActivePrinter & " <Unavailable>"

End If

End Sub

Private Sub GetPrinterNameAndPort(printerName As String, _
printerPort As String)
' ActivePrinter yields a name of the form "Printer XYZ on LPT1" while the
' DeviceCapabilities function requires a printer name and port.
'
' Out:
' printerName Printer name derived from ActivePrinter property
' printerPort Printer port derived from ActivePrinter property

Dim sString As String
Const searchText As String = " on "

sString = ActivePrinter
printerName = Left(sString, InStr(1, sString, searchText) - 1)
printerPort = Right(sString, _
Len(sString) - Len(printerName) - Len(searchText))

End Sub

※support.microsoft.comのサンプルコードなのに・・・・

回答No.1

m3_maki

> ※support.microsoft.comのサンプルコードなのに・・・・

機械翻訳のページですから、
当然、２バイトコードを含む日本語に対応するカスタマイズなどされていませんね。

こちらは Access用ですが、日本語対応です。

プリンタが印字できる用紙名　ＩＤの取得
http://www.geocities.jp/shaku_tyo/tip/050609.htm

ちょこっと修正すれば Excel でも動きます。

【修正点】
・データベースではないので、DAO の参照設定は不要。
・db、ｒｓ の定義不要。
・結果を Access のテーブルに書き出すロジック不要。
・Access の Printer オブジェクトの機能は Excel の ActivePrinter には存在しないので
　プリンタ名を取得するロジックは Microsoft のものを使用する。
・Excel のシートに書き出す機能を追加。
以上。

> さらに言えば、メッセージボックスでなくワークシートのセルに書き出したいです。

これが自力でできないレベルでは、「ちょこっと修正」は無理かな？

大サービス、用紙のID と 用紙名を 現在のシートに書き出します。
------------------------------------------
Option Explicit

' プリンタデバイスドライバの能力を取得する関数の宣言
Private Declare Function DeviceCapabilities Lib "winspool.drv" Alias "DeviceCapabilitiesA" (ByVal pDevice As String, ByVal pPort As String, ByVal fwCapability As Long, pOutput As Any, pDevMode As Any) As Long
' ある位置から別の位置にメモリブロックを移動する関数の宣言
Private Declare Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

' DeviceCapabilities function constants.
Private Const DC_PAPERNAMES = 16
Private Const DC_PAPERS = 2
Private Const DC_BINNAMES = 12
Private Const DC_BINS = 6
Private Const DEFAULT_VALUES = 0

Sub GetPaperList()

Dim strDeviceName As String
Dim strDevicePort As String
Dim lngPaperCount As Long
Dim bytPaper() As Byte
Dim strPaperName As String * 64
Dim lngCounter As Long
Dim aintNubytPaper() As Integer
Dim lngRet As Long

' Excel用
GetPrinterNameAndPort strDeviceName, strDevicePort

' 問い合わせる内容を指定
' バッファに必要なサイズを取得
lngPaperCount = DeviceCapabilities(strDeviceName, strDevicePort, DC_PAPERNAMES, ByVal vbNullString, ByVal vbNullString)
' バッファ確保
ReDim bytPaper(64 - 1, lngPaperCount - 1)
ReDim aintNubytPaper(1 To lngPaperCount)

'用紙名を取得
DeviceCapabilities strDeviceName, strDevicePort, DC_PAPERNAMES, bytPaper(0, 0), ByVal vbNullString
'paper numbers を取得
lngRet = DeviceCapabilities(strDeviceName, strDevicePort, DC_PAPERS, aintNubytPaper(1), ByVal vbNullString)

'用紙名を列挙
For lngCounter = 0 To lngPaperCount - 1
　　' 用紙名コピー
　　MoveMemory ByVal strPaperName, bytPaper(0, lngCounter), 64
　　' 用紙名追加
　　'Debug.Print Left(strPaperName, InStr(strPaperName, vbNullChar) - 1) & " " & aintNubytPaper(lngCounter + 1)
　　' Excel用
　　Cells(lngCounter + 1, 1) = aintNubytPaper(lngCounter + 1)
　　Cells(lngCounter + 1, 2) = Left(strPaperName, InStr(strPaperName, vbNullChar) - 1)
Next lngCounter

MsgBox "取得完了"

End Sub

Private Sub GetPrinterNameAndPort(printerName As String, _
　　　　　　　　　　　　　　 printerPort As String)
' ActivePrinter yields a name of the form "Printer XYZ on LPT1" while the
' DeviceCapabilities function requires a printer name and port.
'
' Out:
' printerName Printer name derived from ActivePrinter property
' printerPort Printer port derived from ActivePrinter property

　　 Dim sString As String
　　Const searchText As String = " on "

　　sString = ActivePrinter
　　printerName = Left(sString, InStr(1, sString, searchText) - 1)
　　printerPort = Right(sString, _
　　　　 Len(sString) - Len(printerName) - Len(searchText))

End Sub

シートをクリアしたりなどという処理は含まれていません。
あとは、ご自由にカスタマイズしてください。
しゃくさんに感謝!