|
Option Explicit
Private Declare Function RcvMail Lib "bsmtp" _
(szServer As String, szUser As String, szPass As String, szCommand As String, szDir As String) As Variant
Private Declare Function ReadMail Lib "bsmtp" _
(szFilename As String, szPara As String, szDir As String) As Variant
'メールを読む
Private Function ExMailRead(lrow As Long, sfina As String) As Long
Dim szFilename As String
Dim szPara As String
Dim szDir As String
Dim retva As Variant
Dim vr As Variant
'メール受信のファイル名
szFilename = sfina
'添付ファイルが保存されるディレクトリ
szDir = Range("F6")
'読むヘッダーの項目
szPara = "subject:from:date:"
retva = ReadMail(szFilename, szPara, szDir)
If IsArray(retva) Then
For Each vr In retva
'内容を表示
Range("F" & lrow) = vr
lrow = lrow + 1
Next
Else
Range("F" & lrow) = vr
End If
lrow = lrow + 1
'行を返す
ExMailRead = lrow
End Function
Private Sub ExRecvMail()
Dim szServer As String
Dim szUser As String
Dim szPass As String
Dim szCommand As String
Dim szDir As String
Dim aret As Variant
Dim va As Variant
Dim n As Long
szServer = Range("F3") '受信メールサーバー名
szUser = Range("F4") 'メールアカウント
szPass = Range("F5") 'パスワード
szCommand = "SAVEALL" '受信数 SAVEALLで全て受信
szDir = Range("F6") '受信したメールの保存先フォルダ
'受信実行
aret = RcvMail(szServer, szUser, szPass, szCommand, szDir)
n = 8 '受信したメールファイル名の表示開始行
If IsArray(aret) Then '正常終了の場合、戻り値は配列になる
For Each va In aret
Range("E" & n) = "受信ファイル："
'メールファイル名を表示
Range("F" & n) = va
'メールを読む
n = ExMailRead(n + 1, Range("F" & n))
Next
Else
Range("F" & n) = aret 'エラーの場合はメッセージを表示
End If
End Sub
Private Sub CommandButton1_Click()
ExRecvMail
End Sub
|
|
