エクセルでセル内容でpdfで保存しメールの起動まで

質問

いつもお世話になっております。
ここで絶大なる支援を受けて表題に関するいくつかのマクロを教えていただいて色んな定常作業に組み込んで非常に便利に使い始めたのですが、下記の組み合わせが試行錯誤（当方の実力）ではどうしても達成出来ないのでHELPです。
１．エクセルの複数の指定セルを繋げてファイル名にする。
　　A1セルが「赤」、B1セルが「色」の場合はファイル名を「赤色」としたい。
２．上記のファイルを指定のパスのホルダーに保存する
３．そのpdfファイルを添付したメール画面でOutlookを起動する。
１．２．＋指定アドレスに送信、まで全自動で完了する完成版はあるのですが、自動送信ではなくメールの起動までの方が非常に汎用性が高いので何とかお願いします。
また、ファイル名に2つのセルの内容をつなぐこともうまくいきませんでした。

回答No.3

watabe007 · ベストアンサー

今晩は、参考に
Sub Test()
　Dim OutlookApp As Object
　Dim OutlookMail As Object
　Dim FilePath As String, FN As String

　'ファイル名の作成
　'A1セルが「赤」、B1セルが「色」の場合はファイル名を「赤色」としたい。
　'A1、B1セルはSheet1に有るものと仮定
　With Worksheets("Sheet1")
　　FN = .Range("A1").Value & .Range("B1").Value & ".pdf"
　End With
　MsgBox "ファイル名は：" & FN
　'上記のファイルを指定のパスのホルダーに保存する
　'指定のホルダーはデスクトップ上の[報告書]ホルダーと仮定
　FilePath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
　FilePath = FilePath & "\報告書\" & FN
　'FilePathの最終確認(確認後、必要なければ削除してください。)
　MsgBox "ファイルパスは：" & FilePath
　'PDFを指定のホルダーに出力
　'PDF出力の対象シートをSheet1と仮定しています。
　Worksheets("Sheet1").ExportAsFixedFormat Type:=xlTypePDF, Filename:=FilePath
　'Outlookを起動
　Set OutlookApp = CreateObject("Outlook.Application")
　Set OutlookMail = OutlookApp.CreateItem(0)
　With OutlookMail
　　.Display '画面を表示
　　.To = "abc@defg.ne.jp"
　　.CC = ""
　　.BCC = ""
　　.Subject = "メールの件名"
　　.Body = "メールの本文"
　　.Attachments.Add FilePath
　　'.Send '自動送信するのならコメントを外してください。
　End With
　Kill FilePath 'PDFファイルを削除
　Set OutlookMail = Nothing
　Set OutlookApp = Nothing
End Sub

お礼

お世話になります。
正月明けに早速試してみたのですが動きません。（ショック！＆やっぱり！）
先ず変えてみたのは下のシート名”Sheet1"とRangeのセル番地を実際のシート名とセル番地に、
”Desktop”を実際のファイルパスに、”報告書”を実際のフォルダー名に変えただけですがコンパイルエラー「構文エラー」となってしまいました。

エラーの内容は、Sub test（）が黄色になって、ＦＮ＝・・の行が赤文字ハイライトになっているのですが、ここは違うはずがないのでその後のファイルパスの不具合かとも思うのですが、後の行（コード）が前の行のエラーになることがあるのでしょうか？

Desk Topの「報告書」フォルダーではできたのに、ファイルパスを変えようとしたらこのレベルなのですがよろしくお願いします。

With Worksheets("Sheet1")
　　FN = .Range("A1").Value & .Range("B1").Value & ".pdf"

　FilePath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
　FilePath = FilePath & "\報告書\" & FN

補足

いつもお世話になっております。

早々にダミーファイルで試してみました。
（私の場合）当然ながら何度かのエラーメッセーに試行錯誤して、デスクトップに「報告書」ファルダーを作成してみたらエラーメッセージが変わったので、よく見たらA1,B1が空白になっていたのでそれぞれに赤、色を入れてみたらメールが起動してきました。
感動！！！

残念ながら実際のファイルは会社なので年明けに動くことを確認して報告とお礼をさせていただきます。

私の場合、実際のファイルで動作確認しないと危ないので何かあればまたよろしくお願いします。

このコードもそろったので、仕事のタイプにより多くのエクセルの作業に汎用に使えそうです。

回答No.8

watabe007

> FilePath = CreateObject("WScript.Shell").SpecialFolders("\＊＊＊＊\？？？
？\XXXチーム\☆検査結果&成績書\サンプル名.原紙.顧客名"
だからCreateObject("WScript.Shell").SpecialFoldersは
デスクトップのパスを取得するときに使うのであって
パスが分かっているのなら
FilePath = "\＊＊＊＊\？？？？\XXXチーム\☆検査結果&成績書\サンプル名.原紙.顧客名"
FilePath = "\＊＊＊＊\ ここぐらいは伏字にする必要がありますか

お礼

手取り足取り、それでも尚 試行錯誤の末、どうにか、やっと動きました。
本当にお手数をおかけしました。
すでに3つのファイルにコピペし、それぞれのホルダーに保存されることまで確認しました。

複数の担当者に使ってもらうことになります。
エクセルは入力しかできない人でも、データ入力後ボタンのワンクリックで指定ホルダーに、規則的なファイル名で保存し、送信まで出来る様になったので大変助かります。

補足

何度もすみませんでした。

自宅でのTESTシートでうまくいったときに、
＞CreateObject("WScript.Shell").SpecialFolders
の意味が全く分からなかったので、実際のフォルダーで確認しないと危ないと思い、
＞私の場合、実際のファイルで動作確認しないと危ないので何かあればまたよろしくお願いします。

として、BSを保留していました。

回答No.7

watabe007

>指定のホルダーはデスクトップ上の[報告書]ホルダーと仮定
>FilePath = CreateObject("WScript.Shell").SpecialFolders("\\＊＊＊＊\？？？>\XXXチーム\☆検査結果&成績書\サンプル名\1.原紙\1.顧客名")
SpecialFoldersはデスクトップのパスを知るために使っているので
パスが分かっているのなら
FilePath = "C:\XXXチーム\☆検査結果&成績書\サンプル名\1.原紙\1.顧客名"
又はネットワーク上なら
FilePath = "\\＊＊＊＊\？？？>\XXXチーム\☆検査結果&成績書\サンプル名\1.原紙\1.顧客名"

回答No.6

watabe007

>With Worksheets("統合版(提出)")
>FN = .Range("B10").Value & .Range("D10).Value & ".pdf"
>End With
　" を1つ忘れていますよ
.Range("D10").Value

補足

本当に出来が悪くて済みません。

ご指摘の個所を修正したらメールが起動して、宛先、件名、本文が入っているのですが、最後に「実行時エラー」「オートメーションエラーです」「指定されたファイルが見つかりません」と出ます。

シート名は実際のシート名に2か所変更しました。

マクロ実行時のメッセージとして、ファイル名とファイルパスが出るのですが両方ともファイル名と同じなのですが、パスがおかしいのでしょうか？

自宅でのDeskTopに作った”報告書”のフォルダーではうまくいったのと同じ個所を変更していると思うのですが。
（ファイルパスは違っていますが）
自宅では確認メッセージの省略も出来たのですが。。。

Sub Test()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim FilePath As String, FN As String

'ファイル名の作成
'A1セルが「赤」、B1セルが「色」の場合はファイル名を「赤色」としたい。
'A1、B1セルはSheet1に有るものと仮定
With Worksheets("提出用")
FN = .Range("B10").Value & .Range("D10").Value & ".pdf"
End With
MsgBox "ファイル名は：" & FN
'上記のファイルを指定のパスのホルダーに保存する
'指定のホルダーはデスクトップ上の[報告書]ホルダーと仮定
FilePath = CreateObject("WScript.Shell").SpecialFolders("\\＊＊＊＊\？？？\XXXチーム\☆検査結果&成績書\サンプル名\1.原紙\1.顧客名")
FilePath = FilePath & FN
'FilePathの最終確認(確認後、必要なければ削除してください。)
MsgBox "ファイルパスは：" & FilePath
'PDFを指定のホルダーに出力
'PDF出力の対象シートをSheet1と仮定しています。
Worksheets("提出用").ExportAsFixedFormat Type:=xlTypePDF, Filename:=FilePath
'Outlookを起動
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.Display '画面を表示
.To = "abc@defg.ne.jp"
.CC = ""
.BCC = ""
.Subject = "メールの件名"
.Body = "メールの本文"
.Attachments.Add FilePath
'.Send '自動送信するのならコメントを外してください。
End With
Kill FilePath 'PDFファイルを削除
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub

回答No.5

watabe007

>エラーの内容は、Sub test（）が黄色になって、
>ＦＮ＝・・の行が赤文字ハイライトになっているのですが
なら、ここが間違っているのでしょう
実際に使ったコードをアップしてみてください。

補足

Sub Test()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim FilePath As String, FN As String

'ファイル名の作成
'A1セルが「赤」、B1セルが「色」の場合はファイル名を「赤色」としたい。
'A1、B1セルはSheet1に有るものと仮定
With Worksheets("統合版(提出)")
FN = .Range("B10").Value & .Range("D10).Value & ".pdf"
End With
MsgBox "ファイル名は：" & FN
'上記のファイルを指定のパスのホルダーに保存する
'指定のホルダーはデスクトップ上の[報告書]ホルダーと仮定
FilePath = CreateObject("WScript.Shell").SpecialFolders("\\＊＊＊＊\？？？\XXXチーム\☆検査結果&成績書\サンプル名\1.原紙\1.顧客名")

教えていただいたコードを丸ごとコピペして、セル番地をファイルパスをいじっただけのはずなのですが。
ファイルパスは希望のフォルダーをシフト＋右クリックで「パスのコピー」で貼り付けました。

回答No.4

mt2015

ANo.1です。

既に先回りしてマクロを作った回答があるので、回答ではなく補足されたコードについて1点だけ……。

> FilePath = "\\Srv01\結果表\" & strSub & Format(Now(), "yymmdd hhmm") & ".pdf"
> 'Sheet3の結果表の特定のセルに品名
> strSub = Worksheets("結果").Range("E14").Value & "試験結果" & "LOT " & Range("E19")

変数「strSub」に文字列を代入する前の空の状態で、変数「FilePath」の文字列を作るために使用しています。

> > また、ファイル名に2つのセルの内容をつなぐこともうまくいきませんでした。

の原因はこれでは？

お礼

度々のアドバイスありがとうございます。
少し試してみたのですが、やはりうまくいきませんでした。
自分でも情けない状態で残念です。
お手数をおかけしました。

回答No.2

HohoPapa

https://www.extendoffice.com/ja/documents/excel/4412-excel-save-as-pdf-and-email.html
↑に
>１．２．＋指定アドレスに送信、まで全自動で完了する完成版はあるのですが
のコードがあるようです。

これを期待の動作に修正したコードを下記します。
コメントアウトした行は必要に応じて削除してください。

Option Explicit

Sub Saveaspdfandsend()
Dim xSht As Worksheet
'Dim xFileDlg As FileDialog
Dim xFolder As String
'Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

Const PdfDir = "C:\OKWave"　　'PDFを保存するフォルダー

Set xSht = ActiveSheet
'Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
'
'If xFileDlg.Show = True Then
'　 xFolder = xFileDlg.SelectedItems(1)
'Else
'　 MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
'　 Exit Sub
'End If
xFolder = PdfDir + "\" + xSht.Cells(1, 1).Value & xSht.Cells(1, 2).Value + ".pdf"

'Check if file already exist
'If Len(Dir(xFolder)) > 0 Then
'　　xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
'　　　　　　　　　　　vbYesNo + vbQuestion, "File Exists")
'　　On Error Resume Next
'　　If xYesorNo = vbYes Then
'　　　　Kill xFolder
'　　Else
'　　　　MsgBox "if you don't overwrite the existing PDF, I can't continue." _
'　　　　　　　　　　& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
'　　　　Exit Sub
'　　End If
'　　If Err.Number <> 0 Then
'　　　　MsgBox "Unable to delete existing file.　Please make sure the file is not open or write protected." _
'　　　　　　　　　　& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
'　　　　Exit Sub
'　　End If
'End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
　　'Save as PDF file
　　xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

　　'Create Outlook email
　　Set xOutlookObj = CreateObject("Outlook.Application")
　　Set xEmailObj = xOutlookObj.CreateItem(0)
　　With xEmailObj
　　　　.Display
　　　　.To = ""
　　　　.CC = ""
　　　　.Subject = ""
　　　　.Attachments.Add xFolder
　　　　'If DisplayEmail = False Then
　　　　　　'.Send
　　　　'End If
　　End With
Else
　MsgBox "The active worksheet cannot be blank"
　Exit Sub
End If
End Sub

お礼

いつもありがとうございます。

お手数をおかけして本当に申し訳けありませんが今回は＃No3のコードを使わせていただきます。

補足

早々に試してみたのですが、「実行時エラー'1004'：アプリケーション定義またはオブジェクト定義のエラーです。と出ます。
私の実力ではどこが違うのか全くチンプンカンプンです。

＃No3さんのコードで試しても同じエラーが出たのですが、デスクトップに「報告書」というホルダーを作って、それでもエラーが出たのでA1とB1に文字を入れてみたら希望通りに動きました。

このレベルですので残念ながらご回答いただいたコードは動かせる自信がないので諦めます。

回答No.1

mt2015

> １．２．＋指定アドレスに送信、まで全自動で完了する完成版はあるのですが

で、あればそのプログラムに手を入れた方が早いでしょう。

> また、ファイル名に2つのセルの内容をつなぐこともうまくいきませんでした。

上手く行かなかったと言うこの部分のコードと、実際にメールを送信する部分のコードを提示してください。

補足

使っているコードを記載すべきと思ったのですが、色々思考錯誤してやっと動くようになったので下手に削除すると動かなくなってしまって、部分的に修正していただいたコードが動かなくなる可能性があると思い記載しませんでした。
一応下記のコードです。

Sub Test()
Dim FilePath As String, strSub As String
Dim OutlookApp As Object
Dim OutlookMail As Object

'On Error Resume Next
FilePath = "\\Srv01\結果表\" & strSub & Format(Now(), "yymmdd hhmm") & ".pdf"
'Sheet3の結果表の特定のセルに品名
strSub = Worksheets("結果").Range("E14").Value & "試験結果" & "LOT " & Range("E19")
Worksheets("試験結果").ExportAsFixedFormat Type:=xlTypePDF, Filename:=FilePath
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail
.To = "　"
.CC = "　"
.BCC = "　"
.Subject = strSub
.Body = "いつもお世話になっております。" & vbLf & "表題の件、添付の通りです。 " & vbLf & " " & vbLf & "　　　　　ABC(株)　業務課"
.Attachments.Add FilePath

End With
MsgBox "送信完了"
End Sub