エクセルをVBAでOUTLOOKで送信したい（再）

質問

数年前にエクセルをPDFにして添付ファイルとしてOUTLOOKで送信するコードを教えてもらって毎日のように便利に使っているのですが、今回は元のマクロ付きエクセルのまま同じことがしたく、試行錯誤でpdfをxlmsに変えてみたら、メールは起動して来るのですが
「ファイルが見つかりません」とエクセルが添付されません。
どなたかどこを修正すれば良いのかHELPお願いします。

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 = "\\XXXX\TEST報告書成績表" '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(22, 5).Value & " " & xSht.Cells(1, 1).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 = "-----.co.jp"
.CC = "----.co.jp"
.Subject = "XXX報告書" & " " & Range("D10")
.Body = "お疲れ様です。" & vbLf & "表題の件、添付の通りです。 " & vbLf & " " & vbLf & "営業部"
.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

回答No.14

HohoPapa · ベストアンサー

課題や状況を改めて整理してみました。

やりたいことは、
・マクロを含む複数シートがある。
・このマクロブックを複数人でやり取りしながら作業を進める
・そのため、このマクロブックをメールでキャッチボールしたい
・だから、このマクロブック自身をメールで送信できるようにしたい。
と理解しました。

過日私の示した#11のコードは、繰り返しますが、
やっていることは以下です。
>>・自身を上書き保存する
>>・FileSystemObjectを使い、自身を指定のフォルダーに指定のファイル名で複写
>>・この複写先ファイルをメールで送信

自身を指定のフォルダーに指定のファイル名で複写しているのは、
送信控えを残すことを私がイメージし、
そのように望んでいるものと判断したからです。

一方、
>＞Windows("1.新規・変更登録申請書(原紙)･ﾘｽﾄ②T用.xlsm").Activate
>が黄色になって止まります。
これが起きるのは、
先に案内した、
>>・FileSystemObjectを使い、自身を指定のフォルダーに指定のファイル名で複写
この作業によってマクロブックのファイル名が
元のファイル名と異なるファイル名になっているからと思います。
つまり、課題マクロブックは、ファイル名が
"1.新規・変更登録申請書(原紙)･ﾘｽﾄ②T用.xlsm"
であることが必須なコードになっているものと思われます。

であれば、後記のように、
元のファイル名のまま、所定のフォルダーに複写し
これを送信するようにすればいいのではないかと思います。

Sub Sample2()

　Dim xSht As Worksheet
　Dim xFolder As String
　Dim xOutlookObj As Object
　Dim xEmailObj As Object
　Dim fso As FileSystemObject　　　　 'FileSystemObjectのインスタンス用変数

　'FileSystemObjectの参照設定が必要
　Set fso = CreateObject("Scripting.FileSystemObject")
　Const PdfDir = "\\127.0.0.1\TestDir"
　'Const PdfDir = "\\XXXX\TEST報告書成績表"　 '自身を保存するフォルダー

　ThisWorkbook.Save

　Set xSht = ActiveSheet
　xFolder = PdfDir & "\" & ThisWorkbook.Name

　'Debug.Print ThisWorkbook.FullName
　'Debug.Print xFolder

　fso.CopyFile ThisWorkbook.FullName, xFolder

　Set xOutlookObj = CreateObject("Outlook.Application")
　Set xEmailObj = xOutlookObj.CreateItem(0)
　With xEmailObj
　　.Display
　　.To = "-----.co.jp"
　　.CC = "----.co.jp"
　　.Subject = "XXX報告書" & " " & Range("D10")
　　.Body = "お疲れ様です。" & vbLf & "表題の件、添付の通りです。 " & vbLf & " " & vbLf & "営業部"
　　.Attachments.Add xFolder
　End With

End Sub

お礼

今回はご丁寧な指導で
・・予めFileSystemObjectを参照設定
が出来るようになりましたが、残念ですが別の方法での対処を検討します。

久々にHohoPapaさんとコミできたので安心？しました。
上記方法でトラブったらまた宜しくお願いします

HohoPapaさんの意図した動作は1発で動いたことには改めて感動しました。
今回は当方の背景の説明不足のためにお手数をお掛けしてしまいました。ごめんなさい！

補足

お正月に孫のところへ出かけていたので対応が遅れ申し訳ありません。

出社早々にためしてみました。
マクロ付きの自身のファイルの保存とメール送信までは問題ないのですが、メールに添付されたエクセルのマクロを動かすとやはり同じところで止まります。

休み中に色々考えたのですが、過去にHohoPapaさんに教えて頂いたシート（自身）のコピーを保存するコードと指定セルの内容を一覧表の下に参照するコードがあるので、別々に動かすことにトライしてみます。

今回質問したコードは顧客様にメールで送るためのコード（HohoPapa作）でこれの修正が簡単かと思いましたが、他のVBAとの相性があるので当方にはハードル高しと判断し、一旦締め切らせて頂きます。

回答No.13

kkkkkm

あと、思い出したのはテストとして手動で
該当シートのタブで右クリックして「移動またはコピー」で移動先を「新しいブック」にして新しくできたブックを指定のフォルダにマクロ付のブックで保存してみてください。

上記の操作を以下の部分で実行しているだけです。
最初からコードをステップ実行したら上記の動き(ダイアログは出ませんが新規ブックが前面に表示される)が見れると思います

xSht.Copy
ActiveWorkbook.SaveAs xFolder, FileFormat:=xlOpenXMLWorkbookMacroEnabled

手動でも保存ができないのでしたら、今回のマクロとかの問題ではなくシート自体に問題がある可能性が大なので、その場合は別の質問でということになります。

「質問は現状のコードの修正なので」と書いたら焦ってその修正バージョンを回答するくらいのかまってちゃんか何か回答してくれるかもしれませんね。

お礼

何度ものご丁寧なご回答（ご指導）に感謝！、感謝！！

途方のレベルが低すぎる事、色んなマクロが仕込んであるので相性？問題が発生してしまい当方のレベルではハードルが高すぎたと反省しています。

既存のコードを少し修正すれば出来ると思ったのが素人考えでした。
コピーシートをメールで送る、添付エクセルのシートの既存のコードでマクロを動かす、という2段マクロは当方の説明では回答者の忖度だけでは無理だと認識しましたので一旦締め切らせて頂きます、

お手数をお掛けしてしまい申し訳ありませんでした。

回答No.12

kkkkkm

後から参加するのはいいけど、参加する以前のやりとりに目を通さずに馬が回答してますが
(そもそもファイルのコピーを送信するという方法は何度も提案していますね)

本人の希望は
エクセルファイルの1枚のシートをメールしたい
なのでその方向で目新しい回答でもしたらと思うけど、単に相手にして欲しいための回答(かまってちゃん回答)なのかなぁ。

あと、akira0723さんに伝え忘れてましたが

> ご回答の
> xSht.Copy
> ActiveWorkbook.SaveAs xFolder, FileFormat:=xlOpenXMLWorkbookMacroEnabled
> ActiveWorkbook.Close
>
> にしたらpdfでもxlsmでも拡張子を変えるだけで動くことも分かりました。

それは単に〇〇.pdfという名前のファイルが添付できただけで中身はxlsmだと思いますよ。
添付されたファイルをクリックしてpdfとして開くか、もしくは保存されたファイルで確認してみてくださいね。

拡張子をxlsmしたときにエラーになった環境でpdfにしたらエラーにならなかったというのでしたら、それはそれで原因が絞り込めるかもしれませんね。

回答No.11

HohoPapa

誤字があったので書き換えます。

正月休みで時間が取れたので#7のアプローチではなく
>今回は元のマクロ付きエクセルのまま同じことがしたく
この求めを実行するコードを書いてみました。
可能な限り、元のコードを生かしています。

やっていることは以下です。
・自身を上書き保存する
・FileSystemObjectを使い、自身を指定のフォルダーに指定のファイル名で複写
・この複写先ファイルをメールで送信

このコードを実行するには、予めFileSystemObjectを参照設定する必要があります。
よくわからない場合は、
https://www.limecode.jp/entry/syntax/bind-set-filesystemobject
を参照してください。

他のコードの影響でエラーになるかもしれません。その場合は、
エラーとなる行の前後数行とメッセージ全文を教えてください。

期待通り動作するようなら、PdfDirという定数は
例えば、BookDirとでもしたほうが誤解しにくいと思います。

Option Explicit

Sub Sample1()

　Dim xSht As Worksheet
　Dim xFolder As String
　Dim xOutlookObj As Object
　Dim xEmailObj As Object
　Dim fso As FileSystemObject　　　　 'FileSystemObjectのインスタンス用変数

　'FileSystemObjectの参照設定が必要
　Set fso = CreateObject("Scripting.FileSystemObject")
　Const PdfDir = "\\127.0.0.1\TestDir"
　'Const PdfDir = "\\XXXX\TEST報告書成績表"　 '自身を保存するフォルダー

　ThisWorkbook.Save

　Set xSht = ActiveSheet
　xFolder = PdfDir & "\" & xSht.Cells(22, 5).Value & "" & xSht.Cells(1, 1).Value & ".xlsm"

　'Debug.Print ThisWorkbook.FullName
　'Debug.Print xFolder

　fso.CopyFile ThisWorkbook.FullName, xFolder

　Set xOutlookObj = CreateObject("Outlook.Application")
　Set xEmailObj = xOutlookObj.CreateItem(0)
　With xEmailObj
　　.Display
　　.To = "-----.co.jp"
　　.CC = "----.co.jp"
　　.Subject = "XXX報告書" & " " & Range("D10")
　　.Body = "お疲れ様です。" & vbLf & "表題の件、添付の通りです。 " & vbLf & " " & vbLf & "営業部"
　　.Attachments.Add xFolder
　End With

End Sub

補足

Hoho-Papaさん
お久しぶりです。
明けましておめでとうございます。
当方も最近はこれまでのVBAの改良（と言えるほどでもないですが）、VBAの結合とメンテでここへの質問頻度が落ちています。（おかげ様で当方に出来る事はホボ完了した感じです）
かなり前に貰ったVBAは最近改めて色んな部署に展開されつつあります。

さて、
正月休み明け早々に試してみました。
結果は今回の質問（課題）に関しては、また驚きの一発完動＆感動しました。

但し、送ったマクロ付きのエクセルのVBAが不調になってしまって結局意味なし状態。

元々、当方にはハードルが高いとのご指摘もあり、これ以上のご回答は不要、、、と言いつつ一応下記してみます。簡単な事かもしれないので・・・（全く人任せ）

元は申請書に必要事項を入力後、マクロボタンで、PDFでの保存と同じBookの別のシートにセル内容をリストアップし、印刷するようになっていました。
過去にご回答頂いたマクロと「マクロの記録」マクロの結合等々で。

今回入力作業を2人で分けることになったので入力途中のシートをメールで送って、2人目がこれに追記した後で元々のマクロでPDF保存と印刷とリストへの転記をしたかったのです。

送ったエクセル（実際は保存されたマクロ付きエクセル）で元のVBA（下記）を動かすと

＞Windows("1.新規・変更登録申請書(原紙)･ﾘｽﾄ②T用.xlsm").Activate
が黄色になって止まります。
この部分を思いつく限り試行しましたがダメでした。こここだけなら何とかお願いしたいのですが、全く仕掛けを変えるなら手動との合わせ技で行きます。

久しぶりにいつものおんぶに抱っこ＋忖度に依存しての補足で、これ以上の補足は止めます。当方には無理。

Sub 申請書登録()
Dim NewBookName As String

With ThisWorkbook.Sheets("申請書")

Windows("1.新規・変更登録申請書(原紙)･ﾘｽﾄ②T用.xlsm").Activate
For i = 5 To Sheets("規格登録・変更ﾘｽﾄ").Range("A1048576").End(xlUp).Row + 1
If Sheets("規格登録・変更ﾘｽﾄ").Range("B" & i).Value = "" Then

With Sheets("規格登録・変更ﾘｽﾄ")
.Range("A" & i).Value = Sheets("申請書").Range("E3").Value
.Range("B" & i).Value = Sheets("申請書").Range("O3").Value
.Range("C" & i).Value = Sheets("申請書").Range("E4").Value
.Range("D" & i).Value = Sheets("申請書").Range("E5").Value
.Range("E" & i).Value = Sheets("申請書").Range("U5").Value
.Range("F" & i).Value = Sheets("申請書").Range("F20").Value
' .Range("B" & i).Value = Date

End With
Exit For
End If
Next
Sheets("規格登録・変更ﾘｽﾄ").Select

End With
End Sub

回答No.10

HohoPapa

正月休みで時間が取れたので#7のアプローチではなく
>今回は元のマクロ付きエクセルのまま同じことがしたく
この求めを実行するコードを書いてみました。
可能な限り、元のコードを生かしています。

やっていることは以下です。
・自身を上書き保存する
・FileSystemObjectを使い、自身を指定のフォルダーに指定のファイル名で複写
・この複写先にファイルをメールで送信

このコードを実行するには、予めFileSystemObjectを参照設定する必要があります。
よくわからない場合は、
https://www.limecode.jp/entry/syntax/bind-set-filesystemobject
を参照してください。

他のコードの影響でエラーになるかもしれません。その場合は、
エラーとなる行の前後数行とメッセージ全文を教えてください。

期待通り動作するようなら、PdfDirという定数は
例えば、BookDirとでもしたほうが誤解しにくいと思います。

Option Explicit

Sub Sample1()

　Dim xSht As Worksheet
　Dim xFolder As String
　Dim xOutlookObj As Object
　Dim xEmailObj As Object
　Dim fso As FileSystemObject　　　　 'FileSystemObjectのインスタンス用変数

　'FileSystemObjectの参照設定が必要
　Set fso = CreateObject("Scripting.FileSystemObject")
　Const PdfDir = "\\127.0.0.1\TestDir"
　'Const PdfDir = "\\XXXX\TEST報告書成績表"　 '自身を保存するフォルダー

　ThisWorkbook.Save

　Set xSht = ActiveSheet
　xFolder = PdfDir & "\" & xSht.Cells(22, 5).Value & "" & xSht.Cells(1, 1).Value & ".xlsm"

　'Debug.Print ThisWorkbook.FullName
　'Debug.Print xFolder

　fso.CopyFile ThisWorkbook.FullName, xFolder

　Set xOutlookObj = CreateObject("Outlook.Application")
　Set xEmailObj = xOutlookObj.CreateItem(0)
　With xEmailObj
　　.Display
　　.To = "-----.co.jp"
　　.CC = "----.co.jp"
　　.Subject = "XXX報告書" & " " & Range("D10")
　　.Body = "お疲れ様です。" & vbLf & "表題の件、添付の通りです。 " & vbLf & " " & vbLf & "営業部"
　　.Attachments.Add xFolder
　End With

End Sub

回答No.9

kkkkkm

あと回答No.3で言った

ThisWorkbook.SaveCopyAs xFolder
は試したのでしょうか

回答No.8

kkkkkm

自信のコピーを作成してそのコピーをメールしているのだから・・・以下略

質問は現状のコードの修正ですので、それ以外の事に話が及びそうですからそういうのは何度も言いますがこちらではなく別途質問を挙げてそちらで好きに話し合ってくださいね。

回答No.7

HohoPapa

久々に訪れてみたら、
見覚えのある「akira0723さん」の名前があるので、
参加させてもらいます。

akira0723さんのことですから、
質問内容にポストしたソースコードのほかにも記述があり
質問文だけでは洞察できないイベントを拾ったコードが記載されているものと推測します。

>今回は元のマクロ付きエクセルのまま同じことがしたく
やること自身はとてもシンプルに見えますが
自身に、
自身をメールで送信する機能を付加するのは
なかなかハードルが高く、私だったらやりません。
全体の動作やイベント、コードを知る尽くしたうえで実装する必要があります。
自身をPDF化して送信するのと同等レベルの話ではありません。

むしろ、
OUTLOOKで送信するだけのマクロブック（※１）を用意し
そのマクロブックを実行するとエクセルブック
（あるいは、PDFファイルなど任意ファイル）
を選択する画面を表示し
そこで選択したブックをoutlookが送信するようにすれば、
動作は安定するものと思います。
送信するマクロブックのフルパスが固定なら、
そのフルパスを※1のシートに予め書き込んでおくという仕様も考えられます。

そうすれば、
.To = "-----.co.jp"
.CC = "----.co.jp"
.Subject = "XXX報告書" & " " & Range("D10")
.Body = "お疲れ様です。" & vbLf & "表題の件、添付の通りです。 " & vbLf & " " & vbLf & "営業部"
といった送信先や件名、メール本文などを※１のシートに埋め込むことが可能となり
汎用性も広がるだろうと思います。

どのようなインターフェースにしたいかを説明してくれれば
コードを提示できると思います。

回答No.6

kkkkkm

> と言うことで目的のBookでは動かず、正常なエクセルに送りたいシートをコピーしてもダメでした。

シートが壊れているのかもしれませんが、実際のブックを触れるのはakira0723さんなのでこちらでは何もすることはありません。
ただ、正常なブックでは正常に動くという事なので
エクセルをVBAでOUTLOOKで送信したい
という希望はコード的には達成できていますから、ブックやシートの不具合に関しては別の話になります。
それについて何かしらの回答を希望する場合は、その件について別途新たに質問をあげてください。

ということで、この質問に関してはここまでにして閉じてください。

回答No.5

kkkkkm

> 新しいBookにするのが確実だと思うのですが、そうすると他のシートのマクロのメンテが必要になり

このコードだけ新規のブックでテストするということで新規にすべて移すという事ではありません。
新規で正常ならコードではなく現状のブックに問題があるという事になります。
そのあたりを見極めてみてはという事です。

補足

色々試してみました。

１．現在PDFファイルで期待通りに動くファイルでご回答の部分を変更して実行するとチャンとマクロ付きのエクセルが指定のフォルダに保存されて、OLが起動してきて期待通りの動きでメールが送れる状態になりました。

２．このコードをそっくりコピーして、目的のエクセルのシートモードにコピペして実行すると「オブジェクトが・・・（だったと思う）」メッセージがでてエラーになり何も起こりません。

３．１．のエクセルに２の目的のシートをコピーして１.のエクセルで実行しても２．と同じ結果でエラーMsgが出て止まります。

と言うことで目的のBookでは動かず、正常なエクセルに送りたいシートをコピーしてもダメでした。

当方には何か基本的な常識、知識が抜けているように思います。

ご回答の
xSht.Copy
ActiveWorkbook.SaveAs xFolder, FileFormat:=xlOpenXMLWorkbookMacroEnabled
ActiveWorkbook.Close

にしたらpdfでもxlsmでも拡張子を変えるだけで動くことも分かりました。これは今後参考になります。（問題が解決すれば）

回答No.4

kkkkkm

あと保存先をローカルにするとかファイル名を変更してみるとか、新しいブックで試してみるとか、環境を変化させてテストしてください。

補足

ハイ！
でいるだけ早急に色々試してみたいのですが、年末に付き諸々あるので、もうしばらく気長にお付き合いくださいませ。

新しいBookにするのが確実だと思うのですが、そうすると他のシートのマクロのメンテが必要になり、また別の問題をご相談することになりそうです。

いづれにしても今後とも何卒宜しくお願いします。