[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『Paste出来ない。VBAエラー』（みかん）
表題の件で悩んでいます。
マクロでExcelで作成した表(C1:E2セル)をOutlookのメールに貼り付けたいのですが、
.Pasteの部分でエラーで止まります。
エラーの種類は「5097 問題が発生しました」です。
何か月もこのコードを使用して問題なく動いていたのですが、突然止まるようになってしまいました。
Windowsのアップデートとか関係しているのかと思い、複数PCで試した所、
恐らく最近のアップデートが入っていないPCで稼働すると動きました。
このような場合、何か思い当たる回避方法ご存じの方いらっしゃいましたら教えて下さい。
不思議なのは、今回止まってしまうのは、普通にCopy → Pasteした場合で、
図で貼る場合（Copypicture → Paste）の場合はエラーになりません。
（表にリンク等がついている為、図にはしたくない）
下記にエラーになる場合とならない場合を記載しました。
よろしくお願いいたします。
Sub メール()
Dim myoutlook As Object
Dim mail As Object
Set myoutlook = CreateObject("outlook.application")
Set mail = myoutlook.CreateItem(0)
With mail
.To = Sheets("sheet1").Cells(1, 1)
.Subject = Sheets("sheet1").Cells(2, 1)
.Display
With mail.GetInspector.WordEditor.Windows(1).Selection
body1 = Sheets("sheet1").Cells(3, 1)
body2 = Sheets("sheet1").Cells(4, 1)
.typetext body1
.typetext Chr(13)
.typetext body2
.typetext Chr(13)
Sheets("sheet1").Range(Sheets("sheet1").Cells(1, 3), Sheets("sheet1").Cells(2, 5)).Copy
.Paste '←ここでエラーになります！！！
.typetext Chr(13)
Sheets("sheet1").Range(Sheets("sheet1").Cells(1, 3), Sheets("sheet1").Cells(2, 5)).Copy
.Paste '←図で貼るとエラーになりません！！
End With
End With
mail.Save
Set myoutlook = Nothing
Set mail = Nothing
End Sub
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
再現できなかったですが、別の方法があるようなので試してみたらいかがでしょう？ https://fastclassinfo.com/entry/excelvba_outlook_data_with_table/#VBA-2 ↑は単純にHTMLの文字列を張り付けているだけなので、リスクは低いのかなーと
再現に使ったコード
Sub メール()
Dim myoutlook As Object
Dim mail As Object
Dim ws As Worksheet
Dim myBody As String
Set ws = Sheets("Sheet1")
Set myoutlook = CreateObject("outlook.application")
Set mail = myoutlook.CreateItem(0)
With mail
.To = ws.[A1].Value
.Subject = ws.[A2].Value
.Display
With mail.GetInspector.WordEditor.Windows(1).Selection
myBody = myBody & ws.[A3].Value & vbCrLf
myBody = myBody & ws.[A4].Value & vbCrLf
.typetext myBody
ws.[B1:E2].Copy
.Paste '←ここでエラーになります！！！
.typetext vbCrLf
ws.[B1:E2].CopyPicture
.Paste '←図で貼るとエラーになりません！！
End With
End With
mail.Save
Set myoutlook = Nothing
Set mail = Nothing
End Sub
（稲葉） 2022/12/17(土) 20:14:03
（みかん） 2022/12/17(土) 23:46:28
例えば、
ws.[B1:E2].Copyの部分の、[B1:E2] ですが、
毎回最終行が不明だとしてLastRowで取得したりしたいので、直接指定できない場合、[ ]で囲むのはどのようにすれば良いのでしょうか。
ws.[Range(ws.Cells(1, 2), ws.Cells(LastRow, 5))].copyでは動かなくて、Rangeを変数に格納してみても同様にエラーとなってしまいました。
（ [ ]の意味合いがよく理解できていません）
マクロ勉強中で基本的な事が分かったおらず申し訳ないですが、宜しくお願いします。
（みかん） 2022/12/18(日) 10:07:18
下記のような表だとして、 最終列に当たるC列が、歯抜けがあって最終行が取りにくい場合 A列の最終行からEnd(xlup)というやり方がいいのかなと思います。
|[A] |[B] |[C]
[1]|名前|性別 |備考
[2]|佐藤|男 |
[3]|伊藤|女 |人事
[4]|斎藤|その他|
[5]|武藤|女 |総務
[6]|後藤|男 |
Sub test()
Dim ws As Worksheet
Set ws = ActiveSheet
Debug.Print ws.Range("C1", ws.Cells(Rows.Count, "A").End(xlUp)).Address(0, 0)
End Sub
[A1]表記について、[]内に変数は使えません。 覚えなくてもいいけど、使っている人がいたら読める程度で十分かなと・・・。
参考サイト https://qiita.com/Q11Q/items/b9d78202977810b7f889
自分ルール Worksheet.[A1] ・・・決め打ちのセルアドレスはこっちを使う。シート名の修飾子をつけて、Evaluateと見分けられるように。
Cellsの第二引数は、変数を使わない限り列の文字を使う。可読性をよくするため
例）Range("A1") を置き換えるときは、Cells(1,"A")とする
2回以上繰り替えすオブジェクトは、なるべく変数に入れる
set ws = Sheet("Sheet1") など
改行はvbCrLfを使う
LastRowを変数として使う書き方をする場合
LastRow = ws.Cells(ws.Rows.count,"A").End(xlUp).Row
ws.Range("A1:C" & LastRow).copy
のように使います。
折角Rangeは文字列使えるので！
（稲葉） 2022/12/18(日) 11:10:49
ご親切に色々とご説明ありがとうございました！
可読性を良くする事は重要ですね。
まだそのような書き方が出来ていないので、今後意識していきたいと思います。
＞ [A1]表記について、[]内に変数は使えません。
理解しました。参考リンクもありがとうございます。
＞ ws.Range("A1:C" & LastRow).copy のように使います。
Range + Cell で組み合わせるよりも、あとで分かりやすいですね。
今後これも意識してみます。
勉強になりました。ありがとうございます。
（みかん） 2022/12/18(日) 11:28:20
★エラー→デバック→この状態で、Outlookの下書きフォルダをクリックする→エラーで黄色くなっている構文を無視してマクロ再開
やはり、ExcelとOutlook間の連携がうまく行ってないのでしょうか。
そこで、.Paste の直前に、Outlookの下書きトレイを選択する構文を追加したらどうかとチャレンジしているのですが、
新たに下書きトレイを開く方法は分かったものの、今使っている下書きトレイそのものをアクティブにする書き方が色々TRYするもうまくいきません。分かる方がいらっしゃいましたら、ご教授頂きたく…。
新たに開く方法↓これだと、これまで同様、 .Paste部分でエラーとなります。
Dim OL As Outlook.Application
Dim NS As Namespace
Set OL = CreateObject("Outlook.Application")
Set NS = OL.GetNamespace("MAPI")
NS.GetDefaultFolder(olFolderDrafts).Display
別Windowsで開くのではなく、アクティブにする方法も調べたのですが↓、2行目のApplicationの所で、オブジェクトはこのプロパティまたはメソッドをサポートしてませんと出てしまう。
Dim NS As Outlook.Namespace
Set NS = Application.GetNamespace("MAPI")
Set Application.ActiveExplorer.CurrentFolder = NS.Folders("下書き")
どうしても出来なければ、メッセージボックスで「下書きトレイを選択してから再開して下さい」という一文を追加しようかと考えています…苦笑。
宜しくお願いいたします。
（みかん） 2023/01/20(金) 04:30:09
Pasteと下書きトレイが繋がらないんですけど、コード全文乗せて貰えませんか？ Outlookは門外漢なので、お答え出来ないかも知れません （稲葉） 2023/01/20(金) 06:12:09
.Paste '←★★ここでエラーになります！！！
この構文の前に、今開いているOutlookの下書きトレイにメールが生成されています。
.Pasteの構文を実行前に、下書きトレイをアクティブ？にした状態にしておくと、マクロが最後まで流れる事を発見したので、その構文の前に先ほど記載した構文を追加すればどうか…と考えた次第です。
Sub メール()
Dim myoutlook As Object
Dim mail As Object
Set myoutlook = CreateObject("outlook.application")
Set mail = myoutlook.CreateItem(0)
With mail
.To = Sheets("sheet1").Cells(1, 1)
.Subject = Sheets("sheet1").Cells(2, 1)
.Display
With mail.GetInspector.WordEditor.Windows(1).Selection
body1 = Sheets("sheet1").Cells(3, 1)
body2 = Sheets("sheet1").Cells(4, 1)
.typetext body1
.typetext Chr(13)
.typetext body2
.typetext Chr(13)
Sheets("sheet1").Range(Sheets("sheet1").Cells(1, 3), Sheets("sheet1").Cells(2, 5)).Copy
.Paste '←★★ここでエラーになります！！！
.typetext Chr(13)
Sheets("sheet1").Range(Sheets("sheet1").Cells(1, 3), Sheets("sheet1").Cells(2, 5)).Copy
.Paste '←図で貼るとエラーになりません！！
End With
End With
mail.Save
Set myoutlook = Nothing
Set mail = Nothing
End Sub
（みかん） 2023/01/20(金) 10:01:13
ああ、ごめんたぶんDisplayのせいじゃないかなぁ
これで問題ないと思うけど・・・
Sub メール()
Dim myoutlook As Object
Dim mail As Object
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Set myoutlook = CreateObject("outlook.application")
Set mail = myoutlook.CreateItem(0)
With mail
.To = ws.Range("A1")
.Subject = ws.Range("A2")
'.Display
With mail.GetInspector.WordEditor.Windows(1).Selection
.typetext ws.Range("C1").Value
.typetext Chr(13)
.typetext ws.Range("D1").Value
.typetext Chr(13)
ws.Range("C1:E2").Copy
.Paste '←★★ここでエラーになります！！！
End With
End With
mail.Save
Set myoutlook = Nothing
Set mail = Nothing
End Sub
（稲葉） 2023/01/20(金) 11:54:29
With mail.GetInspector.WordEditor.Windows(1).Selection
で、操作は失敗しました。のエラーが出てしまいました。
（みかん） 2023/01/20(金) 12:43:20
こっちは全く問題が発生しないので対応のしようがないですね・・・ Stopで止まるので、ローカルウィンドウでType確認してください。 問題なく取得できていれば、wdWindowDocumentのはず・・・
門外漢で、こちらも調べながらやってるので、これ以上の対応は難しそうです。 すみません。 先の投稿でHTMLを張り付ける方法も検討してください。 もしくは、表を文字として出力するなども。
Sub メール()
Dim myoutlook As Object
Dim mail As Object
Dim wdDoc As Object
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Set myoutlook = CreateObject("outlook.application")
Set mail = myoutlook.CreateItem(0)
With mail
.To = ws.Range("A1").Value
.Subject = ws.Range("A2").Value
'.Display
Set wdDoc = mail.GetInspector().WordEditor.Windows(1)
Stop 'ここで、wdDocに値が入っているか確認してください
With wdDoc.Selection
.typetext CStr(ws.Range("C1").Value)
.typetext Chr(13)
.typetext CStr(ws.Range("D1").Value)
.typetext Chr(13)
ws.Range("C1:E2").Copy
.Paste '←★★ここでエラーになります！！！
End With
.Save
.display
End With
Set myoutlook = Nothing
Set mail = Nothing
End Sub
（稲葉） 2023/01/20(金) 15:12:11
ポイントは
Set wdDoc = mail.GetInspector().WordEditor.Windows(1)
でちゃんとオブジェクトをSetする事でしょうか。 私のだと、mail.GetInspector.WordEditor.Windows(1).Selectionとしていて、 微妙に記述方法が違う(GetInspectorの後ろに()がないとか…)のも気になります。 また、.Displayの位置も最後に持ってくるのがポイントだったりしますでしょうか。
月曜に試してみます。ありがとうございます！
（みかん） 2023/01/20(金) 20:30:32
色々調べたけど、エラーになる事例が少ないみたい・・・？ 自分で使ってるメール送信にGetInspector.WordEditorを組み入れてみました。 エラーが再現できないので、Nothingの時に、Displayさせてから再評価してみたり、悪あがきしました。
それでもできない場合、下記をFalseに変更すると、HTMLBodyで表を組み込みできます。 ＞Const OutlookStyle As Boolean = True '★標準のスタイルを適応する場合、Trueに設定する
追加で署名と添付ファイルも対応できるようにしたので、よろしければお使いください。
私も勉強になったので、ありがとうございました。
Option Explicit
Type SetMail
宛名 As String
CC As String
件名 As String
本文 As String
表 As String
添付() As String
署名 As String
End Type
Sub メール送信()
'[定数扱い]
Dim oApp As Object 'Outlookオブジェクト
Dim wdDoc As Object 'objMAIL.GetInspector.WordEditorを一時取込、設定の合否を判断する
Const br As String = "<br>" '[HTMLの場合、改行コードを<br>に置き換える
Const strTablePasteChr As String = "[表挿入位置]"
'[ユーザーが設定するもの]
Dim ws As Worksheet '宛先等の設定が入力されているシートを設定する
Dim rngTable As Range '表の範囲をRange型で取得する
Const OutlookStyle As Boolean = True '★標準のスタイルを適応する場合、Trueに設定する
'[宛先や件名等をまとめて管理する変数]
Dim myMail As SetMail 'ユーザー定義型（Type SetMail） 宛名や本文等を見やすくする
'[ループ処理で仮に使用する変数]
Dim i As Long '複数の添付ファイルをループする
Dim tmpAtt As String '添付ファイルの有無をチェックする変数
'[エラー処理]
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If oApp Is Nothing Then MsgBox "アウトルックを起動してから実行してください": Exit Sub
'[★データの設定]
Set ws = Sheets("Sheet1")
Set rngTable = ws.Range("C1:E2")
With myMail
.宛名 = ws.Range("A1").Value
.CC = ""
.件名 = ws.Range("A2").Value
.本文 = .本文 & ws.Range("C1").Value & vbCrLf & vbCrLf
.本文 = .本文 & ws.Range("D1").Value & vbCrLf & vbCrLf
.表 = GetTableRange(rngTable)
.署名 = Get署名
' ReDim .添付(1)
' .添付(0) = "絶対パス1"
' .添付(1) = "絶対パス2"
End With
'[メールアイテムの作成]
With oApp.CreateItem(0) 'olMailItem=0
'[基本情報の入力]
.BodyFormat = 2 'olFormatHTML
.To = myMail.宛名 '宛先
.CC = myMail.CC 'CC
.subject = myMail.件名 '件名
If Not Not myMail.添付 Then
For i = 0 To UBound(myMail.添付)
tmpAtt = myMail.添付(i)
If tmpAtt <> "" Then
If Dir(tmpAtt) = "" Then
If MsgBox("添付ファイルのパスが正しくありません。添付ファイルを追加しないでメールを送りますか？" & vbCrLf & tmpAtt, vbYesNo) = vbNo Then
Exit Sub
End If
Else
.Attachments.Add tmpAtt '添付ファイルの貼り付け
End If
End If
Next i
End If
'[本文の入力方法 OUTLOOKの元のスタイルを適応する場合、True、0から作る場合False]
If OutlookStyle = True Then
'"参考"
'https://hassaku74kg.com/entry/vba-htmlmail-insert-string
'https://stackoverflow.com/questions/38119333/mailitem-getinspector-wordeditor-returns-nothing
'https://www.excel.studio-kazu.jp/kw/20220619181414.html
Do
Set wdDoc = .GetInspector.WordEditor
If wdDoc Is Nothing Then
If .display = False Then
.display
Else
MsgBox ".GetInspector.WordEditor が取得できませんでした。問題が解決しない場合、OutlookStyleをFalseに設定し、HTMLBodyで作成してください"
Exit Sub
End If
Else
Exit Do
End If
Loop
With wdDoc.Range(0)
'本文と署名の間に、表を埋め込む為の文字列を組み入れる
.InsertBefore myMail.本文 _
& strTablePasteChr
'表を埋め込む為の文字列を検索し、指定した範囲の表を貼り付ける
.Find.Text = strTablePasteChr
.Find.Execute
rngTable.Copy
.Paste
End With
Else
myMail.本文 = Replace(myMail.本文, vbCrLf, br)
myMail.署名 = Replace(myMail.署名, vbCrLf, br)
.HTMLBody = myMail.本文 _
& myMail.表 _
& myMail.署名
End If
.display
'.Send '直接送信箱行き
End With
MsgBox "メールを作成しました"
End Sub
'//署名保管フォルダを表示し、取得する
Function Get署名() As String
Dim 署名フォルダ As String
Dim 署名ファイル As String
署名フォルダ = CreateObject("Wscript.Shell").SpecialFolders("AppData") & "\Microsoft\Signatures\"
With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "署名ファイル", "*.txt"
.InitialFileName = 署名フォルダ
.AllowMultiSelect = False
.Title = "署名選択"
If .Show = True Then
署名ファイル = .SelectedItems(1)
End If
End With
If 署名ファイル <> "" Then
Get署名 = CreateObject("Scripting.FileSystemObject").GetFile(署名ファイル).OpenAsTextStream(1, -2).ReadAll
End If
End Function
'//指定範囲をHTMファイルで出力し、文字列として取得
Function GetTableRange(ByVal r As Range) As String
Dim ws As Worksheet: Set ws = r.Parent
Dim wb As Workbook: Set wb = ws.Parent
Dim tmpPATH As String: tmpPATH = CreateObject("Wscript.Shell").SpecialFolders("DeskTop") & "\tmp.htm"
Dim tmpTable As String
If Dir(tmpPATH) <> "" Then Kill tmpPATH
wb.PublishObjects.Add(xlSourceRange, tmpPATH, ws.Name, r.Address, xlHtmlStatic).Publish True
'■//テキストストリームで取得
tmpTable = CreateObject("Scripting.FileSystemObject").OpenTextFile(tmpPATH, 1).ReadAll
tmpTable = Replace(tmpTable, "align=center", "align=Left") '表全体を左寄せに
tmpTable = Replace(tmpTable, "General", "Left") '表内の文字を左寄せに
GetTableRange = tmpTable
Kill tmpPATH
End Function
（稲葉） 2023/01/21(土) 12:57:15
署名と添付も活用させて頂きますね♪
ありがとうございました。
（みかん） 2023/01/21(土) 16:15:21
>Set wdDoc = mail.GetInspector().WordEditor.Windows(1)
With wdDoc.Selection
非常に勉強になりました。
まだまだマクロ初心者ですが、今後引き出しを増やしていけるように頑張りたいと思います。
ありがとうございました。
（みかん） 2023/01/23(月) 18:11:13
今まで5年くらいの間、1か月に50回程度動作させていたマクロでしたが、
2022月12月半ばごろから急にOutlookにPasteする部分で
「5097 問題が発生しました」のエラーが出て動かなくなってしまっていました。
エラーが出たときに、デバッグ画面で黄色いラインが引かれた状態で、
生成されたOutlookメールを手動でアクティブにした後にマクロを再開すると動いたので
それで騙し騙し使っていましたが、2023年2月初旬ごろに突然使えるようになりました。
おそらくWindowsかOutlookのアップデートが関係しているのだと思います。
このような事例もあるのだという記録として書き残しておきます。
（ピロリ） 2023/02/22(水) 10:55:36
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.