HOME > Q&A > Excel （VBA）

Excel （VBA）
Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Microsoft 365)
Excel ファイルのアクティブなシートの選択範囲をメールの本文に貼り付けたい
投稿日時: 24/06/24 15:51:06
投稿者: takatada72

お疲れさまです。
 
下記のコードをCOPILOTに作ってもらいましたが、質問の仕方が悪いせいなのか、
中途半端なものになってしまいました。
 
仕様:アクティブなシートで、セルの選択範囲に罫線を付けて、その範囲をメールの本文
に罫線付きで貼り付けるコードを考えておりました。
 
実行すると、Excel の方には、罫線が付けられるけど、メールの本文には、罫線が付け
られませんでした。何度も、COPILOTに本文にも罫線付けてとお願いしても、改善されな
いため、こちらへ投稿させて頂きました。
どの部分が間違いなのでしょうか
 
お忙しいとは思いますが宜しくお願い致します。
 
Sub xxx2()
  Dim rng As Range
    Dim i As Long, j As Long
    Dim emailBody As String
    Dim mailItem As Object ' Outlook.MailItem
    Dim outlookApp As Object ' Outlook.Application
     
    On Error Resume Next
    Set rng = Selection ' アクティブなセル範囲を取得
    If rng Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
     
    ' セル範囲に罫線を追加
    With rng.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
     
    Set outlookApp = CreateObject("Outlook.Application")
    Set mailItem = outlookApp.CreateItem(0) ' 0はolMailItemを表します
     
 
    For i = 1 To rng.Rows.Count
        For j = 1 To rng.Columns.Count
            emailBody = emailBody & " " & rng.Cells(i, j).Value
        Next j
        emailBody = emailBody & vbNewLine
    Next i
     
    ' メール本文のカスタマイズ
    emailBody = "Hi" & vbLf & vbLf & "ここにメッセージの本文を追加してください" & vbLf & vbLf & emailBody & vbNewLine
     
    With mailItem
        .subject = "テスト" ' メールの件名を設定
        .To = "" ' 宛先のメールアドレスを設定
        .body = emailBody ' メール本文を設定
        .display ' メールを表示
        '.Send ' メールを送信（必要に応じてコメントアウト）
    End With
     
     
    Set mailItem = Nothing
    Set outlookApp = Nothing
    Application.ScreenUpdating = True
 
End Sub
    
回答
投稿日時: 24/06/24 16:54:21
投稿者: sk

引用:
アクティブなシートで、セルの選択範囲に罫線を付けて、
その範囲をメールの本文に罫線付きで貼り付ける

（標準モジュール）
---------------------------------------------------------
Sub CreateMailAndPasteRange()
   
    If TypeName(Selection) <> "Range" Then
        MsgBox "セル範囲が選択されていません。", _
               vbExclamation, _
               "参照エラー"
        Exit Sub
    End If
     
    Dim rngTarget As Excel.Range
     
    Set rngTarget = Selection
     
    With rngTarget.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
     
    Dim olkApp As Object 'Outlook.Application
    Dim olkMailItem As Object 'Outlook.MailItem
   
    On Error Resume Next
    Set olkApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo 0
        Set olkApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
     
    Set olkMailItem = olkApp.CreateItem(0) 'olMailItem
     
    Dim wrdDoc As Object 'Word.Document
     
    With olkMailItem
        .To = ""
        .Subject = "件名"
        .BodyFormat = 1 'olFormatPlain
        .Body = ""
        .BodyFormat = 2 'olFormatHTML
        .Display
        Set wrdDoc = .GetInspector.WordEditor
    End With
         
    rngTarget.Copy
    wrdDoc.Paragraphs(1).Range.PasteExcelTable LinkedToExcel:=False, _
                                               WordFormatting:=False, _
                                               RTF:=False
    Application.CutCopyMode = False
     
    Set wrdDoc = Nothing
    Set olkMailItem = Nothing
    Set olkApp = Nothing
    Set rngTarget = Nothing
 
End Sub
---------------------------------------------------------
 
以上のようなコードを実行できればよい、ということでしょうか。
投稿日時: 24/06/24 17:08:17
投稿者: takatada72

 skさん
 
早速、ありがとうございました。
無事に罫線がメールにつけられました。
 
最初のコードと skさんが示してくれたコードの違いを学びたいと思います。
 
ありがとうございました。