M_MailSend

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
        ' 如果Type为Month 则不论是否为工作日都发信
        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