VBAでExcelファイルのPDF自動化

表題の通りの事をしたいと思っています。とあるサイトで参照したvbaコードで、デスクトップにファイルをExcelのブック名と同じ名前でPDFに変換するところまで出来ました。あと自動でやりたいことは2つあり、(1)とあるセルの情報を読み込み保存名にしたい【○○○.pdfという具合に】、(2)生成したpdfファイルの保存先をマクロ内に設け指定したいです。【\\サーバー名\○○\△△\□□などのように】

現状までのコードを表記します。わかる方いらっしゃいましたら、お手数ですがアドバイスお願いします。
自分はマクロは手を出したばかりで、初心者です。宜しくお願いします。

Sub pdf()
Dim i As Integer
Dim s_prn As String, oldprn As String, flg As Boolean
On Error Resume Next

s_prn = "Adobe PDF" 'インストールされているPDFプリンタの名前
oldprn = ActivePrinter 'アクティブプリンタを取得

If InStr(oldprn, s_prn) = 0 Then '切替えたいプリンタがアクティブプリンタでない場合
flg = False 'プリンタ切替フラグ
For i = 0 To 99
ActivePrinter = s_prn & " on Ne" & Format(i, "00") & ":" '「"プリンタ名"on NeXX:」形式PC用
ActivePrinter = "Ne" & Format(i, "00") & ": の " & s_prn '「NeXX: の "プリンタ名"」形式PC用

If ActivePrinter <> oldprn Then
flg = True 'プリンタ切替成功
Exit For
End If
Next i
If flg = False Then 'プリンタ切替失敗の場合
MsgBox "プリンタ名:" & s_prn & " が見つかりません。"
Exit Sub
End If
End If


ActiveSheet.PrintOut

ActivePrinter = oldprn 'アクティブプリンタを元に戻す
MsgBox "終了しました。"

End Sub

No.5 回答者： mitarashi 回答日時： 2013/12/20 22:31

#2です。

プリンター名決め打ちで良ければもっと簡単な方法がある事が判明しました。
alternativePrinter = getPrinterPort("Microsoft Office Document Image Writer")
のところは、お手元のPCにインストールされているプリンタを設定する必要があります。ダミーで使用するだけで、実際には印刷させません。

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)
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

Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Function

No.4 回答者： mitarashi 回答日時： 2013/12/20 00:30

#3の続きです。

１．Activesheetを、A1セルに入れた文字列をファイル名（pdfは勝手につける）にして、コード中で指定するフォルダーに出力します。コード中のフォルダーは、お手元の環境に合わせて変更が必要です。

２．前準備が必要です。
コントロールパネルのデバイスとプリンタから、
Acrobat PDFをWクリック、メニューのプリンタをクリック、プロパティを選択、
全般タブの基本設定ボタンをクリック、Adobe PDF設定タブの基本設定ボタンをクリック、Adobe PDF設定タブの
「システムのフォントのみ使用し、文書のフォントを使用しない」のチェックを外す必要があります（Acrobat9の場合)
Acrobat6では、フォントを送信しないという表現でした。

これを行わないと、PostScriptファイル出力時にエラーとなります。

３．Excelはシート毎に印刷条件を保持していて、これが邪魔をする事があります。（コントロールパネルでの設定より優先されるらしい）これをクリアするため、面倒な事をしています。

４．あまり役に立たない情報（または言い訳）
VirtualBOX環境で試験したところ、取得されるプリンターリストに余分な情報が含まれていて悩まされました。おかげでコードの推敲は不十分で時間切れです。本来は実行しているPCに出力してから、サーバーにコピーする方が良いでしょう。

以上、ご参考まで。

No.3 回答者： mitarashi 回答日時： 2013/12/20 00:17

#2です。

文字数オーバーのため2分割します。
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

'Activesheetをpdf出力
Sub MakePdf()
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"

printerList = Get_Printers
If UBound(printerList) = 0 Then Exit Sub
For i = LBound(printerList) To UBound(printerList)
If InStr(printerList(i), "Adobe PDF") > 0 Then
acrobatPrinter = printerList(i)
Else
alternativePrinter = printerList(i)
End If
Next i
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

'プリンターのリスト取得0スタートの文字列配列で戻す
'参照：http://blogs.yahoo.co.jp/bardiel_of_may/40864687 …
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) 'xl2000の時
hWnd = 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

Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Functio

No.2 回答者： mitarashi 回答日時： 2013/12/18 22:40

xl2007以降なら、#1さんの例の様に話は簡単なのですが、xl2003以前で、Acrobatを用いて行おうとするとなかなか骨です。

下記リンクがお役に立つのではないかと思います。
http://okwave.jp/qa/q4847920.html
http://okwave.jp/qa/q6205938.html

リンク先に"プリンタ名"on NeXXの取得をレジストリから行う部分もありますが、お示しのコードは泥臭いけれど簡便で良いですね。

行っている事の解説はこちらにあります。今日検索していてたまたま辿り着きました。
http://helpx.adobe.com/jp/legacy/kb/511120.html

ただ、
>デスクトップにファイルをExcelのブック名と同じ名前でPDFに変換するところまで出来ました。
で良いのなら、セルから読んだ名前に付け替えれば簡単かと思います。
保管場所も同様で、カレントディレクトリに出力されるのかどうか分かりませんが、目的の場所にコピーまたは移動してやればよろしいのではないでしょうか。

以上、ご参考まで。

この回答への補足

自分が行おうとしているのは、excel 2003での作業になります。

教えていただきましたリンク内のコードをマクロに記憶させて実行してみましたが’400’というエラーが出てしまいできませんでした。

>セルから読んだ名前に付け替えれば簡単かと思います。
Dim Fname As String
Fname = WorkSheet("Sheet1").Range("A1").value

などとすればいいのでしょうか。
FnameをPDFでの保存名にするには、どうすればいいでしょうか。

>保管場所も同様で、カレントディレクトリに出力されるのかどうか分かりませんが、目的の場所にコピーまたは移動してやればよろしいのではないでしょうか。

現場のオペレーターの方の作業を極力減らしたいので、マクロを走らせただけで、所定のサーバー内にPDF形式でexcelシートを保存したいと考えております。

できれば具体的なコードを示していただけると助かります。
初心者ですいません。宜しくお願い致します。

補足日時：2013/12/19 13:20

No.1 回答者： shut0325 回答日時： 2013/12/18 17:31

単純にPDF形式で保存すればよいかと思います。

コードは

FPath="\\サーバー名\○○\△△\□□\":'最後に￥をつけるのを忘れずに。

FName=ActiveSheet.Range("A1").Value:'仮にファイル名をアクティブシートのセルＡ1の値としています。

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FPath & FName & ".pdf"

こんな感じで。