Outlook VBA 下書きに保存したメールを元に書式を残し置換 MailItem.Copy WordEditorで置換

やりたいこと:
detail.chiebukuro.yahoo.co.jp

＞Outlookで下書きに保存したメールを元に作成してみたいメールがあります。
＞文字列を日付に変換するだけなのですが、
＞下書きに保存したメールには書式があります。
＞OutlookVBAでReplaceしたら書式が消えてしまいました。
＞因みにOutlookのデータをローカルに保存することはできません。

いつものデバッグ動画です
youtu.be
https://youtu.be/wiwvFYsCfBM
目次
00:00 やりたいこと
01:44 メールのチェック Selection.Count
02:34 1.下書きメールを.Copyで複製を作り
05:50 2.GetInspector().WordEditor で編集
06:22 3.編集はWord VBAの置き換えで
07:45 問題点.Copy時点でメールが複製されるのでキャンセル時・・・
08:24 説明まとめ と 再テスト実行(下書き修正手順を解説)

1.下書きメールを.Copyで複製を作り、
learn.microsoft.com

2.GetInspector().WordEditor で編集
learn.microsoft.com

3.編集はWord VBAの置き換え
learn.microsoft.com

をヒントにして、コードを作成。

With objDOC.Content.Find
    .Text = "置換品番"  '置換元
    .Forward = True
    .Replacement.Text = "ABC12345"  '置き換える文字
    .Execute Replace:=2  'wdReplaceAll=2 置換実行

みたいに、置き換えると、

＞下書きに保存したメールには書式があります。
＞OutlookVBAでReplaceしたら書式が消えてしまいました。

書式が残るかなぁ。

下記残念なソースですが

Sub test20220927選択下書きメールのコピーをテスト()

    If Application.ActiveExplorer.Selection.Count <> 1 Then
        MsgBox "下書きメールを一つ選択してください", vbExclamation
        Exit Sub
    End If

    '選択されているアイテムをコピー
    Dim oSelectItem As Object
    Set oSelectItem = ActiveExplorer.Selection.Item(1) '選択されているItemを代入
    
    If TypeName(oSelectItem) <> "MailItem" Then '念のためチェックいらないかな
        MsgBox "MailItem 下書きメールを一つ選択してください", vbExclamation
        Exit Sub
    End If
    
    Dim oMAIL As Outlook.MailItem  'メールアイテム
    oSelectItem.Display '表示してからコピーしないとエラー？なんだろう？
    DoEvents  'これないと、エラー
    Set oMAIL = oSelectItem.Copy   '.Copyで複製を作成、oMailに代入
    '↑これで複製されるので、コピー元はすぐに.Closeで退場する
    oSelectItem.Close olDiscard  'olDiscard:1 変更内容を破棄 そもそもコピー元だしね
    
    '↑でCopy作成したメールを編集する
    'メールの本文を修正、ここでは、置き換えテスト
    oMAIL.Display  '表示する(表示しっぱなし、今回自動送信はしない)
    oMAIL.Subject = Format(Date, "yyyy/mm/dd") & "発注書"  '件名を変更

    Dim n As Long
    Dim objDOC As Object
    Set objDOC = oMAIL.GetInspector().WordEditor
    '↑.WordEditorであとは、Wordの世界っぽく処理

    With objDOC.Content.Find  '置き換えをバカっぽく三回固定値でテスト
        '品番
        .Text = "置換品番"  '置換元、この文字を検索して置換する
        .Forward = True
        .Replacement.Text = "ABC12345"  '置き換える文字
        .Execute Replace:=2  'wdReplaceAll=2 置換実行
    
        '品名
        .Text = "置換品名"  '置換元、この文字を検索して置換する
        .Forward = True
        .Replacement.Text = "Outlook .Copyで下書きメール複製"  '置き換える文字
        .Execute Replace:=2  'wdReplaceAll=2 置換実行
        
        '数量
        .Text = "置換数量"  '置換元、この文字を検索して置換する
        .Forward = True
        n = 1234567  'カンマのチェック用
        .Replacement.Text = Format(n, "#,###,##0")  '置き換える文字
        .Execute Replace:=2  'wdReplaceAll=2 置換実行
        
    End With
    
    MsgBox "処理終了、内容確認後、送信してください"

    '問題点、まずいことに気が付く、メールをコピーしているので、
    '変更を破棄しても、メールが残る・・・
    'おっとっと。まぁ今回は.Copyのテストってことで・・・

End Sub

アレンジして使ってみてください。

何か、勘違い回答をしたような気もしつつ、
解決のヒントとなれば幸いです。