Mail

原创
2018/08/08 07:19
阅读数 18

Option Explicit

Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long

'************************************************************************************************

'* 功能 自动发信

'* 参数

'* 返回值:

'* 备注

'************************************************************************************************

Public Sub SendMail()

Dim i As Integer

On Error GoTo ErrHandler

' 遍历整个数组

For i = 1 To UBound(ConfigData, 1)

' 最后一个标志位为1的是当天已经生成过的文件

If ConfigData(i, C_ISCREATE) = "1" Then

' 如果TypeMonth 则不论是否为工作日都发信

If UCase(ConfigData(i, C_TYPE)) = Type_Month Then

Call Send(i)

' 如果Type不是Month 则休日不发信

ElseIf g_IsHoliday = False Then

Call Send(i)

End If

End If

Next i

Exit Sub

ErrHandler:

Call WriteLog(Log_Error, "SENDMAIL", Err.Description)

End Sub

'************************************************************************************************

'* 功能 自动发信

'* 参数

'* 返回值:

'* 备注

'************************************************************************************************

Private Sub Send(ByVal i As Integer)

Dim Namespace As String

Dim oMsg As Object

Dim strFolder As String

Dim strFileName As String

Dim strFolder2 As String

Dim strFileName2 As String

Dim objFso As Object

Dim objFolder As Object

Dim objFiles As Object

Dim objFile As Object

Dim strFromPath As String

Dim strToPath As String

Dim lngFileLen As Long

Dim fileExistFlg As Boolean

On Error GoTo Error_Mail

Namespace = "http://schemas.microsoft.com/cdo/configuration/"

Set oMsg = CreateObject("CDO.Message")

' 文件不存在

fileExistFlg = False

strFromPath = ""

strToPath = ""

lngFileLen = 0

' From

oMsg.From = ConfigData(i, C_SEND_FROM)

' To

oMsg.To = Replace(ConfigData(i, C_SEND_TO), Chr(10), ",")

' 抄送

oMsg.CC = Replace(ConfigData(i, C_SEND_CC), Chr(10), ",")

' 秘密抄送

oMsg.BCC = Replace(ConfigData(i, C_SEND_BCC), Chr(10), ",")

' 标题

oMsg.Subject = ConfigData(i, C_SEND_TITLE)

' 正文

oMsg.TextBody = ConfigData(i, C_SEND_CONTENT)

Select Case ConfigData(i, C_FILENAME)

' 报警

Case case1

strFileName = zsFileName

strFileName2 = ysFileName

strFolder = Send_Dir

Case Else

Call WriteLog(Log_Warning, "SEND", "" & i & E_MESSAGE2)

Exit Sub

End Select

' 附件

Set objFso = CreateObject("Scripting.FileSystemObject")

Set objFolder = objFso.GetFolder(g_Path & strFolder)

Set objFiles = objFolder.Files

For Each objFile In objFiles

If InStr(objFile.Name, "_" & Format(g_Date, "YYMMDD")) > 0 Then

' 添加附件

oMsg.AddAttachment g_Path & strFolder & objFile.Name

strFromPath = strFromPath & g_Path & strFolder & objFile.Name & " "

lngFileLen = lngFileLen + FileLen(g_Path & strFolder & objFile.Name)

' 文件存在

fileExistFlg = True

End If

Next

' 文件不存在,退出不发信

If fileExistFlg = False Then

Call WriteLog(Log_Prompt, "SEND", ConfigData(i, C_FILENAME) & W_MESSAGE1)

Exit Sub

End If

With oMsg.Configuration.Fields

.Item(Namespace & "sendusing") = 2

.Item(Namespace & "smtpserver") = "smtp.163.com"

'.Item(Namespace & "smtpserver") = "10.237.126.57"

.Item(Namespace & "smtpserverport") = 25

.Item(Namespace & "smtpauthenticate") = 1

.Item(Namespace & "sendusername") = "bstest1@163.com"

.Item(Namespace & "sendpassword") = "zxcvbn"

.Update

End With

oMsg.Send

Set oMsg = Nothing

Call WriteLog(Log_Prompt, "SEND", ConfigData(i, C_FILENAME) & I_MESSAGE1)

Exit Sub

Error_Mail:

Call WriteLog(Log_Error, "SEND", Err.Description)

End Sub

展开阅读全文
打赏
0
0 收藏
分享

作者的其它热门文章

加载中
更多评论
打赏
0 评论
0 收藏
0
分享
返回顶部
顶部