保存数据库的副本，然后将其通过电子邮件发送到共享电子邮件框

Question

我有一个脚本，可以将备份数据库（带日期邮票）保存到共享驱动器中。

Private Sub Command0_Click()
    Dim fs As Object Dim oldPath As String, newPath As String 
    Dim CurrentDate As String
    CurrentDate = Format(Now, "MMDDYY")
    oldPath = "\xxxxxx Database" 'Folder file is located in 
    'newPath = "\xxxxxxFINANCEUSERSxxxxxx Operationsxxxxxx" 'Folder to copy file to 
    newPath = "C:UsersxxxDocumentsxxxxxx" 'Folder to copy file to
    Set fs = CreateObject("Scripting.FileSystemObject") 
    fs.CopyFile oldPath & "" & "xxx Database Update v.1.6_be.accdb", newPath & "" _
    & "xxx Database Update v.1.6_be_" & CurrentDate & ".accdb"
    Set fs = Nothing
    MsgBox "Database Backed up", , "Backup Complete" 
End Sub

这很好。

但是，现在我被要求将数据库发送到共享的收件箱电子邮件地址。

Private Sub btnbrowse_click()
    Dim filediag As FileDialog
    Dim file As Variant
    Set filediag = FileDialog(msofiledialogfilepicker)
    filediag.allowmultiselect = False
    If filediag.show Then
        For Each file In filediag.selecteditems
        Me.txtattachment = file
        Next
    End If
End Sub
Private Sub btnSend_Click()
    Dim oApp As New Outlook.Application
    Dim oEmail As Outlook.MailItem
    Set oEmail = oApp.CreateItem(olMailItem)
    oEmail.To = Me.txtto
    oEmail.Subject = Me.txtsubject
    oEmail.Body = Me.txtbody
    If Len(Me.txtattachment) > 0 Then
        oEmail.Attachments.Add Me.txtattachment.Value
    End If
    With oEmail
        If Not IsNull(.To) And Not IsNull(.Subject) And Not IsNull(.Body) Then
            .Send
            MsgBox "Email Sent!"
        Else
            MsgBox "Please fill out the required fields."
        End If
    End With       
End Sub

请有人可以帮助我链接两个脚本，以便我可以使用第一个查询中的路径来选择附件，而不是使用FileDialog选择电子邮件附件，并且该脚本将同时运行保存文件和电子邮件同一文件命令。

Answer 1

它只是文件名，因此它可能只是从脚本传递值：

oEmail.Attachments.Add newPath & "xxx Database Update v.1.6_be_" & CurrentDate & ".accdb"

Answer 2

如果您只想在备份后自动发送，请将电子邮件代码作为一个可以在备份按钮中调用的子单击过程。

Sub SendEmail(strFile As String)
...
oEmail.Attachments.Add strFile
...
End Sub

然后在备份按钮的末尾调用子单击：

SendEmail(newPath & "xxx Database Update v.1.6_be_" & CurrentDate & ".accdb")

许多电子邮件系统由于恶意代码风险而拒绝使用访问文件作为附件的电子邮件。但是，zipperiped访问文件应通过安全性。示例代码：

Dim strZip As String
strZip = CurrentProject.Path & "Construction.zip"
'create empty zip folder
'found this on web, no idea what the Print line does but if it isn't there, this won't work
Open strZip For Output As #1
Print #1, "PK" & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
'copy file into zip folder
Dim objApp As Object
Set objApp = CreateObject("Shell.Application")
'variable for source file doesn't seem to work in this line
'also double parens not in original example code but won't work without
objApp.NameSpace((strZip)).CopyHere CurrentProject.Path & "Construction.accdb"

正如代码注释中指出的那样，问题是通过变量传递源文件。抱歉，我永远不需要解决。

创建zip文件代码可以在电子邮件过程中，然后附加zip文件：

oEmail.Attachments.Add strZip

然后在电子邮件过程结束时可以删除zip文件：
Kill strZip