| |
皆さん、こんばんは
このサイトで、良く出てくる
・エクセルでメールを受信する
という事を参考にして、
＃１ メールを受信する
＃２ メールをテキストファイルに保存する
＃３ 指定したフォルダ内にあるテキストを、別シートに貼り付ける
という事までは、出来ました。
メール本文内に、
http://www.yahoo.co.jp
などのようにサイトアドレスがある場合、
IEで表示させたいのですが、どうすれば実現できますか？
それと、表示後に自動的にIEを閉じる操作をしたいのですが
可能ですか？
参考までに、作成したコードはこちらです。
よろしくお願いいたします。
-------------------------------------------------------------------------
Dim ファイル数 As Variant
Dim fname(9999) As Variant ' メール数９９９９通 メール本文２０００行まで対応します
Dim i As Variant
Dim j As Variant
Dim dat As Variant
Dim szServer As String, szUser As String, szPass As String
Dim szCommand As String, szDir As String
Dim ar As Variant, v As Variant
'ReadMail関数用宣言文
Dim szFilename As String, szPara As String
Dim retv As Variant
szServer = Workbooks("エクセルでメール受信と クリックを実現する.xls"). _
Worksheets("メール受信").Cells(4, 2)
'SMTPサーバ名と同じでよい。
'タブで区切ってポート番号を指定できます。
szUser = Workbooks("エクセルでメール受信と クリックを実現する.xls"). _
Worksheets("メール受信").Cells(2, 2)
'メールアカウント名
szPass = Workbooks("エクセルでメール受信と クリックを実現する.xls"). _
Worksheets("メール受信").Cells(3, 2)
'パスワード
' 2000/05/20 APOPをサポート
' APOP 認証をするには、パスワードの前に "a" または "A" に １個の
' ブランクをつけます｡
' "a xxxx" : サーバがAPOP 未対応なら通常のUSER/PASS 処理をします。
' "A xxxx" : サーバがAPOP 未対応ならエラーになります。
If Workbooks("エクセルでメール受信と クリックを実現する.xls"). _
Worksheets("メール受信").Cells(6, 2) = "削除する" Then
szCommand = "savealld" ' 削除する
Else
szCommand = "saveall" ' 削除しない
End If
szDir = Workbooks("エクセルでメール受信と クリックを実現する.xls"). _
Worksheets("メール受信").Cells(5, 2)
'受信したメールを保存するディレクトリ
' ディレクトリが見つからない場合は、ディレクトリを作成する
'-----------------------------------------------------------------------
On Error GoTo ディレクトリ作成済み
MkDir szDir
ディレクトリ作成済み:
'------------------------------------------------------------------------
ar = RcvMail(szServer, szUser, szPass, szCommand, szDir)
'戻り値が返る変数は、Variantタイプを指定すること。
'受信したメール１通ごとにファイルが作成されます。
'メールに添付されたファイルは、本文と共に１つのファイルに含まれます。
'ReadMail関数で添付ファイルを取出します。
If IsArray(ar) Then '正常終了時のSAVEコマンドの戻り値は、配列になります。
For Each v In ar
Debug.Print v 'メールデータが保存されたファイル名がフルパスで戻ります。
'このファイル名をReadMailのパラメータとして渡します。
Next
Else
Debug.Print ar 'エラー発生時は、配列でなくメッセージが戻ります。
End If
'===============================================メールを 読む=================
szFilename = ar(0) ' ファイル名にはRcvMailの戻り値の配列からファイル名を設定
szPara = "subject:from:date:" ' ヘッダーの指定
' nofile: とすると添付ファイルを保存しません。
retv = ReadMail(szFilename, szPara, szDir)
If IsArray(retv) Then
For Each v In retv
Debug.Print v
Next
Else
Debug.Print retv
End If
'--------------------------------------------メールをメール受信に貼り付ける
' 全ファイル名を、fname(i)に取得する
With Application.FileSearch
.LookIn = szDir
.filename = "*.txt"
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
ファイル数 = .FoundFiles.Count
For i = 1 To .FoundFiles.Count
fname(i) = .FoundFiles(i)
Next i
Else
MsgBox "メールファイルがありません"
End If
End With
For i = 1 To ファイル数
' 範囲のクリア
Workbooks("エクセルでメール受信と クリックを実現する.xls").Worksheets("メール本文").Select
Worksheets("メール本文").Range("A1:A9999").Select
Selection.ClearContents
j = 0
' データの貼り付け
Open fname(i) For Input As #1
Do Until EOF(1)
Input #1, dat
j = j + 1
Workbooks("エクセルでメール受信と クリックを実現する.xls").Worksheets("メール本文").Cells(j, 1) = dat
If j = 2000 Then
GoTo skip
End If
Loop
skip:
Close #1
' MsgBox "確認して下さい"
Next i
Workbooks("エクセルでメール受信と クリックを実現する.xls").Worksheets("メール受信").Select
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
