[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロで作成した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 >
(γ) 2019/03/14(木) 22:04
背景色あり、枠線なしのExcelのセル範囲を、値貼付するのが希望に近いです。
枠線は取ってあるのですが、Excelの表をそのまま貼り付けると透明(水色)の線が付いた状態になりますよね。
それも取ってしまいたいので、Excel側の書式を整えても無駄でした。
(あき) 2019/03/15(金) 13:18
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
(γ) 2019/03/16(土) 09:23
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.