GDIplusCODE



必要性は大いに疑問ですが、Windows7 / xl2010の環境でも動作する事が判明しました。C:\ドライブ直下のファイルはダメですけどね。
Acrobat9の場合、Acorbat6の頃とは設定箇所の表現が変わっています。コントロールパネルのデバイスとプリンタから、
Acrobat PDFをWクリック、メニューのプリンタをクリック、プロパティを選択、
全般タブの基本設定ボタンをクリック、Adobe PDF設定タブの基本設定ボタンをクリック、Adobe PDF設定タブの
「システムのフォントのみ使用し、文書のフォントを使用しない」のチェックを外す必要があります

なお、VirtualBOX環境でのテストではWindowsAPIで取得できるプリンターに、実際はプリンタで無いものが含まれていてエラー原因となりました。

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 Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Const KEY_QUERY_VALUE = &H1
Private Const HKEY_CURRENT_USER = &H80000001

'ブックの各シートを、ファイル名にシート名をつけてpdf生成　純正Acrobatインストールが前提
Sub MakePdf()
  Dim wbk As Workbook
  Dim sh As Worksheet
  Dim objAbDist As Object ' ACRODISTXLib.PdfDistiller
  Dim strDefaultPrinter As String
  Dim printerList() As String
  Dim i As Long
  Dim acrobatPrinter As String, alternativePrinter As String

  printerList = Get_Printers
  If UBound(printerList) = 0 Then Exit Sub
  For i = LBound(printerList) To UBound(printerList)
    If InStr(printerList(i), "PDF") > 0 Then
      acrobatPrinter = printerList(i)
    Else
      alternativePrinter = printerList(i)
    End If
  Next i
  Set objAbDist = CreateObject("PdfDistiller.PdfDistiller.1")
  strDefaultPrinter = Application.ActivePrinter
  Set wbk = Workbooks.Open("C:\Test.xls")
  Application.ActivePrinter = alternativePrinter '"DocuWorks Printer on Ne00:"
  Application.ActivePrinter = acrobatPrinter '"Adobe PDF on Ne01:"
  Application.ScreenUpdating = False
  For Each sh In wbk.Worksheets
    sh.PrintOut Copies:=1, preview:=False, _
    printtofile:=True, Collate:=True, prtofilename:="C:\temp.ps"
    objAbDist.FileToPDF "C:\temp.ps", "C:\" & sh.Name & ".pdf", vbNullString
    If Dir("C:\" & sh.Name & ".pdf") <> "" Then Kill "C:\" & sh.Name & ".log"
  Next sh
  wbk.Close savechanges:=False
  Application.ActivePrinter = strDefaultPrinter
  Application.ScreenUpdating = True
End Sub

'プリンターのリスト取得0スタートの文字列配列で戻す
'参照：http://blogs.yahoo.co.jp/bardiel_of_may/40864687.html
Private Function Get_Printers() As String()
  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
  ReDim Preserve sTemp2(0 To ctr - 1)
  For i = 0 To ctr - 1
      sTemp1 = RegRead_API(HKEY_CURRENT_USER, SUB_ROOT, sPrinterList(i))
      sTemp1 = Replace(sTemp1, "winspool,", "")
      sTemp2(i) = sPrinterList(i) & " on " & sTemp1
  Next
  Get_Printers = sTemp2
Exit_Proc:
  Set objPrinter = Nothing
  Set objWSH = Nothing
End Function

'レジストリを開く・読み込む・閉じる。
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 = FindWindow("XLMAIN", Application.Caption) 'Application.hWnd
    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

'☆　おまけ　プリンター名決め打ち出来る時は、WindowsAPIを使わずに、Adobe PDF on Ne01:の形でプリンタが取得できる事がわかりました。

Sub MakePdf2()
  Dim sh As Worksheet
  Dim objAbDist As Object
  Dim strDefaultPrinter As String
  Dim printerList() As String
  Dim i As Long
  Dim acrobatPrinter As String, alternativePrinter As String
  Const destFolder As String = "E:\pdfTest"

    acrobatPrinter = getPrinterPort("Adobe PDF")
    alternativePrinter = getPrinterPort("Microsoft Office Document Image Writer")
  Set objAbDist = CreateObject("PdfDistiller.PdfDistiller.1")
  strDefaultPrinter = Application.ActivePrinter
  Set sh = ActiveSheet
  Application.ActivePrinter = alternativePrinter
  Application.ActivePrinter = acrobatPrinter
  Application.ScreenUpdating = False
    sh.PrintOut Copies:=1, preview:=False, _
    printtofile:=True, Collate:=True, prtofilename:=GetDesktopPath & "\temp.ps"
    objAbDist.FileToPDF GetDesktopPath & "\temp.ps", destFolder & "\" & sh.Range("A1").Value & ".pdf", vbNullString
    If Dir(destFolder & "\" & sh.Range("A1").Value & ".pdf") <> "" Then Kill destFolder & "\" & sh.Range("A1").Value & ".log"
  Application.ActivePrinter = strDefaultPrinter
  Kill GetDesktopPath & "\temp.ps"
  Application.ScreenUpdating = True
End Sub

Function getPrinterPort(printerName As String) As String
    Dim WshShell As Object
    Dim regValue As String
    Dim buf As String
    
    Set WshShell = CreateObject("WScript.Shell")
    On Error Resume Next
    regValue = WshShell.regread("HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Devices\" & printerName)
    If IsNull(regValue) Then
        getPrinterPort = ""
        Exit Function
    End If
    On Error GoTo 0
    buf = Replace(regValue, "winspool,", "")
    buf = printerName & " on " & buf
    getPrinterPort = buf
    Set WshShell = Nothing
End Function
エクセルブックの各シートを、ファイル名=シート名としてpdf生成（本家Acrobatが必要）
