[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『msgファイルを開いてメール転送するには』（おりおん）
こんにちは。初投稿です。よろしくお願いします。
msgファイルはMicrosoft Outlookから保存した1通のメールです
これを別のパソコンで開いて転送しています
エクセルのセルに、
D6・・・保存したUSBのパス(F:\)
D7・・・ファイル名(拡張子はmsg)
D9・・・宛先
D10・・・CC
D11・・・件名の冒頭に追記したい言葉
を入力して、
1.D7に書いてあるファイルを開く
2.「転送」をクリック
3.件名の「FW」という文字を消す
4.宛先欄にD9の情報を入力
5.CC欄にD10の情報を入力
6.件名欄の冒頭にD11の情報を追加入力
ということをしたいのですが、現在は1しかわかりません
2と3は手作業、
4〜6は苦肉の策で、メモ帳に表示して、手作業でコピー貼り付け
という処理をしています
少しでも手作業が減ると嬉しいので
全部でなくても一部分でもヒントでもいいので、
助けていただけないでしょうか?
現在のコード
Sub BO用()
'
'セルD7に書いてあるファイルを開く
Range("D7").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Range("D6").Value & Range("D7").Value, TextToDisplay:=Range("D7").Value
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Selection.Hyperlinks(1).Delete
Range("D6").Copy
Range("D7").PasteSpecial Paste:=xlFormats
' 宛先、CC、件名追記 の情報をメモ帳で表示する
Dim buf As String, CB As New DataObject
buf = "宛先：" & Range("D9").Value & vbCrLf & vbCrLf & "ＣＣ：" & Range("D10").Value & vbCrLf & vbCrLf & "件名追記：" & Range("D11").Value
With CB
.SetText buf ''変数のデータをDataObjectに格納する
.PutInClipboard ''DataObjectのデータをクリップボードに格納する
End With
Dim ret As Long
ret = Shell("Notepad.Exe", vbNormalFocus)
AppActivate ("無題 - メモ帳")
CreateObject("Wscript.Shell").SendKeys "^v"
End Sub
ぼけぼけの間違い訂正です
バージョンは、WinXP、Excel2000 です
よろしくお願いします
追記です
2の「転送」をクリックは、手作業だと「CTRL + f」と同じ
ということまではわかりました
これをマクロでできれば一歩前進なのですが。。
Sub BO用()
'
Range("D9").Copy '宛先の情報
Range("D7").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Range("D6").Value & Range("D7").Value, TextToDisplay:=Range("D7").Value
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
指定時刻 = Now + TimeValue("00:00:02") '現在時刻より2秒後
Application.Wait (指定時刻)
CreateObject("Wscript.Shell").SendKeys "^f"
指定時刻 = Now + TimeValue("00:00:02") '現在時刻より2秒後
Application.Wait (指定時刻)
CreateObject("Wscript.Shell").SendKeys "^v" '宛先の情報を貼り付け
Windows(ThisWorkbook.Name).Activate
Selection.Hyperlinks(1).Delete
Selection.VerticalAlignment = xlCenter
MsgBox "宛先、CC、件名を入力"
End Sub
あとはCCと件名です
よろしくお願いします
なかなか回答付かないですね。 直接の回答ではありません。
こういうことも出来る、という程度のものです。 もっと改造すればお望みのことも出来るかもしれません。
参照設定：Microsoft Outlook xxxx Object Library xxxxはバージョンによって違う
Sub test() Dim myOLApp As Outlook.Application Dim myFolder As Outlook.MAPIFolder Dim itm As Object Dim strpath As String Dim doc As Object Dim ws As Worksheet Dim atcstr As String Dim cnt As Integer
'msgファイルのパス strpath = "C:\test\aaa.msg"
Set myOLApp = CreateObject("Outlook.Application")
Set myFolder = myOLApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
myFolder.Display
'指定のmsgファイルを受信トレイにコピー Set doc = myOLApp.CopyFile(strpath, myFolder) '↓はエラーになる 'MsgBox doc.SenderName & vbCrLf & doc.to & vbCrLf & doc.ReceivedTime & vbCrLf & doc.Subject & vbCrLf & doc.Body
Set ws = ActiveSheet ws.Cells.Delete ws.Cells(1, 1).Value = "送信者" ws.Cells(1, 2).Value = "受信者" ws.Cells(1, 3).Value = "日時" ws.Cells(1, 4).Value = "タイトル" ws.Cells(1, 5).Value = "添付ファイル"
cnt = 1
'受信トレイの各メールアイテムを取得/↑でマクロで受信トレイにコピーしたアイテムはエラーになる
'元から受信トレイにあったものに対応
For Each itm In myFolder.Items
With itm
cnt = cnt + 1
ws.Cells(cnt, 1).Value = .SenderName
ws.Cells(cnt, 2).Value = .to
ws.Cells(cnt, 3).Value = .ReceivedTime
ws.Cells(cnt, 4).Value = .Subject
If .Attachments.Count > 0 Then
atcstr = ""
For Each at In .Attachments
If atcstr <> "" Then atcstr = atcstr & vbLf
'添付ファイルの名前を取得/添付ファイルをPCのコピーする方法もあったように思う
atcstr = atcstr & at.Filename
Next at
ws.Cells(cnt, 5).Value = atcstr
End If
End With
Next itm
Set ws = Nothing
Set doc = Nothing
Set myOLApp = Nothing
Set myFolder = Nothing
End Sub
(カリーニン)
(カリーニン)さんへ、(おりおん)です
休日をはさみお返事が遅れてすみません
サンプルコードをありがとうございました
ただ、残念ながら職場のOutlook 2000では、途中の
'指定のmsgファイルを受信トレイにコピー Set doc = myOLApp.CopyFile(strpath, myFolder) でエラーになってしまいました
別バージョンのOutlookが入っているパソコンがあったら試してみます
自分の頭では、今回の問題にうまく利用するのは難しそうですが、
コードを分解したりして勉強させていただきます
ありがとうございました
> Set doc = myOLApp.CopyFile(strpath, myFolder)
この部分をコメントアウトして、直接手作業でmsgファイルを受信トレイに ドラッグ＆ドロップした場合は
> Set ws = ActiveSheet 以下のコードは作動すると思います。
なお、当方エクセルは2002、ウィンドウズはXPです。
>参照設定：Microsoft Outlook xxxx Object Library >xxxxはバージョンによって違う
↑はされましたよね？ (カリーニン)
(カリーニン)さん、ありがとうございます
>> Set doc = myOLApp.CopyFile(strpath, myFolder) > >この部分をコメントアウトして、直接手作業でmsgファイルを受信トレイに >ドラッグ＆ドロップした場合は > >> Set ws = ActiveSheet >以下のコードは作動すると思います。
はい、コメントアウトしたらその通り出来ました これをすると、最初の「↑でマクロで受信トレイにコピーしたアイテムはエラーになる」は エラーにならないですね! これはこれでなにかに使えそうです ちなみに「受信トレイ」ではなくて、「下書き」とか 受信トレイの中に自分で作った「処理済」なんかに対応するにはどこをどう変えればよいか ご存知でしたら教えていただけますか?
>>参照設定：Microsoft Outlook xxxx Object Library
参照設定もしました
ただ今回は、自分の受信トレイに入れたいのではなくて、 開く→宛先とccと件名を入力→転送 をしたいので、 そこへどう持っていけばいいのかが 今のところわからないですが、、、じっくり考えてみます
ありがとうございました(おりおん)
相変わらずmsgファイルを直接指定して転送するマクロはわかりませんが、OUTLOOK上で 指定のメールアイテムを転送するコードは見つかりました。
ちなみにYahoo検索で「OUTLOOK VBA 転送」で検索しました。
また、OUTLOOKの各フォルダは↓が参考になると思います。
http://d.hatena.ne.jp/ken3memo/20120306/1330966790
最初の投稿で、
>2.「転送」をクリック >3.件名の「FW」という文字を消す
別に転送機能にこだわらずに新規メールアイテムを生成して送信先や宛先、 CC、件名、内容を指定してやればいいような気がしますがそれではダメなん でしょうか？
メール送信に関してはOUTLOOKにこだわりがなければCDOを使う、というのも 選択肢だと思います。
いずれにせよ、OUTLOOK VBAはOUTLOOKの掲示板(があれば、の話ですけど)で 質問された方が解決が早いと思います。
OUTLOOK VBAでのコードがわかればExcel VBAに移植するのは簡単だと思います。
(カリーニン)
(カリーニン)さん、ありがとうございます
>別に転送機能にこだわらずに新規メールアイテムを生成して送信先や宛先、 >CC、件名、内容を指定してやればいいような気がしますが
そうですよね、通常はそれでいけるのですが最近増えたお客様がらみで html形式かつ中国語混じりのメールの場合に、 その方法だと文字化けしてしまうので、 いろいろ試した結果が最初の質問の作業になりました
OUTLOOKでまで調べていただいてありがとうございます URLをたどって勉強してみます
ありがとうございました(おりおん)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.