GDIplusCODE


'http://blogs.yahoo.co.jp/bardiel_of_may/40864687.html
'xl2000用にApplication.hWndがサポートされていないところだけ修正

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
    ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
    lpType As Long, lpData As Any, lpcbData As Long) As Long

Private Const KEY_QUERY_VALUE = &H1
Private Const HKEY_CURRENT_USER = &H80000001
'元コードに追加
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

'追加
'フォームのコマンドボタンへの設定例
Sub ボタン1_Click()
  '結果が出力されたセルの隣に変更間のActivePrinter名を保持する様にしてみた
  Range("プリンタ名").Offset(0, 1).Value = Application.ActivePrinter
  Application.ActivePrinter = Range("プリンタ名").Value
End Sub
Sub ボタン2_Click()
  Application.ActivePrinter = Range("プリンタ名").Offset(0, 1).Value
End Sub

Public Sub Get_Printers()
Dim objWSH As Object
Dim objPrinter As Object
Dim sPrinterList() As String
Dim sTemp1 As String
Dim sTemp2 As String
Dim i As Long
Dim ctr As Long

Const SUB_ROOT = "Software\Microsoft\Windows NT\CurrentVersion\Devices"
    Set objWSH = CreateObject("WScript.Network")
    Set objPrinter = objWSH.EnumPrinterConnections
    If objPrinter.Count < 2 Then
        MsgBox "プリンタを取得できません", vbExclamation
        GoTo Exit_Proc
    Else
        ctr = 0
        For i = 0 To objPrinter.Count - 1 Step 2
            ReDim Preserve sPrinterList(ctr)
            sPrinterList(ctr) = objPrinter(i + 1)
            ctr = ctr + 1
        Next
    End If
    For i = 0 To ctr - 1
        sTemp1 = RegRead_API(HKEY_CURRENT_USER, SUB_ROOT, sPrinterList(i))
        sTemp1 = Replace(sTemp1, "winspool,", "")
        sTemp2 = sTemp2 & sPrinterList(i) & " on " & sTemp1 & ","
    Next
    sTemp2 = Left$(sTemp2, Len(sTemp2) - 1)
    'シートに「プリンタ名」という範囲名をつけておく必要がある
    'そこに入力規則のリストを設定
    With Names("プリンタ名").RefersToRange.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:=sTemp2
    End With

Exit_Proc:
    Set objPrinter = Nothing
    Set objWSH = Nothing
End Sub

'レジストリを開く・読み込む・閉じる。
'Win2000、WinXPでは動作した
'HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Devicesに保存

Private Function RegRead_API(lRoot As Long, sSubRoot As String, sEntryName As String) As String
Dim lRet As Long
Dim hWnd As Long
Dim sVal As String
    'hWnd = Application.hWnd
    hWnd = FindWindow("XLMAIN", Application.Caption)
    lRet = RegOpenKeyEx(lRoot, sSubRoot, 0, KEY_QUERY_VALUE, hWnd)
    sVal = String(255, " ")
    lRet = RegQueryValueEx(hWnd, sEntryName, 0, 0, ByVal sVal, LenB(sVal))
    RegCloseKey hWnd
    sVal = Left$(sVal, InStr(sVal, vbNullChar) - 1)
    RegRead_API = sVal
End Function
プリンタ名のリストをActivePrinterに設定可能な形式で、レジストリから読み出す
