【エクセル/VBA】エクセルシートをPDFで保存→Outlook メールの自動作成

やりたいこと

①エクセルシートで作成した発注書を任意のフォルダにPDF形式で保存

②outlookを立ち上げ、新規メールの作成

③To, cc, タイトル, 本文を自動入力

④作成した発注書を添付

※自動送信もできるが、内容を確認してから送りたいので今回は送信機能はなし

コードは以下の通り

Sub 発注書作成()

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
Dim xSavePath As String

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

'保存するパスの指定
xSavePath = "P:\3.発注書\★2022\オランダ\"

'PDFに保存プログラム
Set xUsedRng = xSht.UsedRange

'PDFのタイトルセル
'**今回はactivesheetのセル"H8"にXXX.pdfの”XXX”の部分を入れている
Set Fname = Cells(8, "H") 

PDFの保存場所とタイトルを変数xFolderに格納
xFolder = ""P:\3.発注書\★2022\オランダ" + "\" + Fname + ".pdf"

If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
   'PDFファイルの保存
   xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xSavePath & Fname & ".pdf", Quality:=xlQualityStandard
   
   'メールの作成
   Set xOutlookObj = CreateObject("Outlook.Application")
   Set xEmailObj = xOutlookObj.CreateItem(0)
   With xEmailObj
       .Display
       .To = Worksheets("発注書のEMAIL").Cells(2, "B")
       .CC = Worksheets("発注書のEMAIL").Cells(3, "B")
       .Subject = Fname + ".pdf"
       .Body = Worksheets("発注書のEMAIL").Cells(4, "B")
       .Attachments.Add xFolder
       If DisplayEmail = False Then
'            .Send　#これのコメントアウトを外せば自動送信可能
       End If

   End With

特記事項

メールの内容は発注書と別に"発注書のEMAIL"というシートに入力をしています。

それぞれのセルは以下の通り
To. =B2
CC = B3
メールタイトル(Subject) = PDFのタイトル名
本文 (Body) = B4