[[20190314183159]] 『マクロで作成したOutlookメールに、Excelの表を貼』(あき) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『マクロで作成したOutlookメールに、Excelの表を貼り付けたときのレイアウトの調整方法』(あき)

ExcelからOutlookを立ち上げてメールを作成するマクロを書いています。
<現状>欄に記載のとおり、わからない部分がありましたので、お知恵を拝借できればと存じます。

<材料>
 ExcelシートA:表が掲載されている
 ExcelシートB:メールの宛先、件名、本文などが記載されている

<目的>
 以下のようなOutlookメールを作成したい。

 宛先:所定の宛先 (シートB・C5セル)
 Cc :所定のCc宛先(シートB・C6セル)
 件名:所定の件名 (シートB・C7セル)
 本文:本文パート1 (シートB・C8セル)
    本文パート2 (シートB・C9セル)
    表     (シートA・A〜E列20行ほど。独自の書式指定あり)
    本文パート3 (シートB・C10セル)

 ※ただし、本文各部の書式は以下とおり。
  パート1:可能な限りシンプルなもの。パート3と同書式。
  パート2:パート1+下線付きで、可能な限りシンプルなもの。
  パート3:可能な限りシンプルなもの。パート1と同書式。

<現状>
 <マクロ>欄に記載のとおりマクロを組んでみましたが、本文で表を挟むことができません(当たり前なんですが…)。
 検討中の案とそれについて困っている部分は以下のとおりです。なにか解決策はありませんでしょうか。
 また、もし表の部分の大きさを調整できる(サイズ指定など)ようであれば、その方法もご教示いただけますと幸いです。

 案?@ パート1だけtypetextで入力する
 →パート3と書式が統一できなくなってしまうのでダメ。
  パート3はこのマクロを操作する以前の操作によって内容が決まるので、typetextでの入力はできない。
  typetextの代わりに、マクロで定義した変数を呼び出せるのであれば、そうしたい。

 案?A 全部activeinspector〜と同じ方法で貼り付ける
 →Excelの枠線や背景色が反映されてしまうのでダメ。
  activeinspector〜の部分で値貼付のようなことができればそうしたい。

<マクロ>
Sub Email_Send()

Dim SheetB As Worksheet
Dim SheetA As Worksheet

Dim dataTop As String
Dim dataBtm As String
Dim dataMain As Range

Dim myAp As Outlook.Application
Dim myMail As Outlook.MailItem

Set SheetB = ThisWorkbook.Worksheets("メール")
Set SheetA = ThisWorkbook.Worksheets("表")

SheetB.Activate
Set myAp = CreateObject("Outlook.Application")
Set myMail = myAp.CreateItem(olMailItem)

With SheetB

    myMail.BodyFormat = 3
    myMail.To = SheetB.Range("C5")
    myMail.CC = SheetB.Range("C6")
    myMail.Subject = SheetB.Range("C7")
  myMail.body = SheetB.Range("C8") & SheetB.Range("C9") & SheetB.Range("C10")
    myMail.Display

  SheetA.Activate
  dataTop = Range("A1").End(xlDown).Address
  dataBtm = Cells(Rows.Count, 5).End(xlUp).Address
  Set dataMain = Range(dataTop, dataBtm)
  dataMain.Copy

  With myAp.ActiveInspector.WordEditor.Windows(1).Selection
   .typetext vbCrLf
   .Paste
  End With

End With

Set myAp = Nothing
Set myMail = Nothing

End Sub

< 使用 Excel:Excel2010、使用 OS:Windows7 >


>Excelの枠線や背景色が反映されてしまうのでダメ。
>activeinspector〜の部分で値貼付のようなことができればそうしたい。
よく読まずに申し訳ないが、
背景色や枠線があるExcelのセル範囲を
Wordに「形式を選択して貼り付け」の中の「どれ」を用いると
あなたの希望に近いのですか?
その範囲のなかで対応するのがよいのではないかと思います。(詳しく知りませんが)
 
それでも不満なら、Excel側の書式を整える(枠線を取る、背景色をとるなど)のが
よいのではないですか?

(γ) 2019/03/14(木) 22:04


>背景色や枠線があるExcelのセル範囲を
>Wordに「形式を選択して貼り付け」の中の「どれ」を用いると
>あなたの希望に近いのですか?
>その範囲のなかで対応するのがよいのではないかと思います。(詳しく知りませんが)

背景色あり、枠線なしのExcelのセル範囲を、値貼付するのが希望に近いです。
枠線は取ってあるのですが、Excelの表をそのまま貼り付けると透明(水色)の線が付いた状態になりますよね。
それも取ってしまいたいので、Excel側の書式を整えても無駄でした。
(あき) 2019/03/15(金) 13:18


横からですがOutlookとの連携について興味があったので考えてみました。
貼付方法ではなく、コピーする方法に着目して【図としてコピー】を使ってみました
もっと良い方法がありそうな気もしますが、参考にシェアします。
【テスト環境】
Windows10、Excel2016、Outlook2016

    Sub 別案()
        Dim SheetB As Worksheet

        '▼宛先等が記載されているシートの定義
        Set SheetB = ThisWorkbook.Worksheets("メール")

        '▼表を【図としてコピー】
        With ThisWorkbook.Worksheets("表")
            With .Range(.Range("A1").End(xlDown), .Cells(.Rows.Count, 5).End(xlUp))
                .CopyPicture Appearance:=xlScreen, Format:=xlPicture '図としてコピー
            End With
        End With

        '▼outlookオブジェクトを生成
        With CreateObject("Outlook.Application")

            '▼新規メールを生成
            With .CreateItem(olMailItem)
                .BodyFormat = olFormatHTML
                .To = SheetB.Range("C5")
                .CC = SheetB.Range("C6")
                .Subject = SheetB.Range("C7")
                .Display

                With .GetInspector.WordEditor.Windows(1).Selection
                    .TypeText SheetB.Range("C8") & SheetB.Range("C9") & SheetB.Range("C10") & vbCrLf
                    .Paste
                End With
            End With
        End With

    End Sub

(もこな2) 2019/03/15(金) 14:39


 こんにちは

 OutLook使ってないので、わからないのですが、
 テキストとして貼り付けるとかできないんでしょうか。

 もしそうだとすると、Excel側で対処する場合
 DataObjectオブジェクトでクリップボードに直接セルのテキストを
 突っ込むという手もあるかもしれません。

 と、最近そういう事例をこの掲示板でみたので思いました。

 dataMain.Copy を TxtCopy2ClipBoard dataMain とかにしてみてください。

 Sub TxtCopy2ClipBoard(ByVal aRange As Range)
  Dim Clip As DataObject
  Dim aRng As Range, aCell As Range, RowValue() As Variant, CellValue() As String
  Dim MaxLen() As Long, r As Long, c As Long, Blnk As String

  Set aRange = aRange.Areas(1)
  ReDim RowValue(1 To aRange.Rows.Count), CellValue(1 To aRange.Columns.Count)
  ReDim MaxLen(1 To aRange.Columns.Count)
  c = 1
  For Each aRng In aRange.Columns
      For Each aCell In aRng.Cells
          MaxLen(c) = IIf(MaxLen(c) > Len(aCell.Text), MaxLen(c), Len(aCell.Text))
      Next
      c = c + 1
  Next
  r = 1
  For Each aRow In aRange.Rows
      c = 1
      For Each aCell In aRow.Cells
          Blnk = String(MaxLen(c), " ")
          Select Case aCell.HorizontalAlignment
             Case xlLeft:   CellValue(c) = Left(aCell.Text & Blnk, MaxLen(c))
             Case xlCenter: CellValue(c) = Mid(Blnk & aCell.Text & Blnk, (MaxLen(c) + Len(aCell.Text)) \ 2 + 1, MaxLen(c))
             Case xlRight:  CellValue(c) = Right(Blnk & aCell.Text, MaxLen(c))
             Case Else:     CellValue(c) = Right(Blnk & aCell.Text, MaxLen(c))
          End Select
          c = c + 1
      Next
      RowValue(r) = Join(CellValue, vbTab)
      r = r + 1
  Next
  Set Clip = New DataObject
  Clip.SetText Join(RowValue, vbLf)
  Clip.PutInClipboard
  Set Clip = Nothing
 End Sub
(でれすけ) 2019/03/15(金) 17:03

ご返事をいただいていましたのに失礼しました。
「値のみ貼り付け」というのはWordにはありませんよね。
Wordにある「形式を選択して貼り付け」のうちのどれで、
という意味でした。(それなら簡単なコードで済みますので)
 
せっかく工夫されたコードが提示されたあとで恐縮ですが、
リッチテキスト形式を使うなら、普通にコピーペイストを
使うのが簡便でよいと思います。
 
>透明(水色)の線が付いた状態
というのは、地の文との区分もつくし、
そのほうが表が見やすかろうと
製品開発者が工夫したものなのでしょう。
 
どうしても線は不要だというなら、
Excel側で罫線の色を「白」(無色ではなく)にしておけば、
Outlook側には水色がつかない表として張り付きます。
(表に見えないリスクは発生しますが)
 
できるだけ既存の機能の範囲でやりくりすることも工夫のうちです。

(γ) 2019/03/16(土) 09:23


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.