|
|
本帖最后由 zfengyue 于 2012-11-20 10:18 编辑
老板要求邮件附件要加密.之前用一个软件手动加密成EXE文件,很繁琐,收件人解密也很麻烦.
现在我想用OUTLOOKVBA来自动完成这个过程.加密写好了.
但是密码通知邮件有些问题.
不知道怎么写.斑竹可不可以给些提示.
我把我已经写好的放上.
应该写得比较乱,初学VBA,大家包涵下.
- Public PW_Mail_Addresses As String
- Public PW_Subject As String
- Public My_PW As String
- Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
- 'On Error GoTo Err
- 'if folders does not exist,then create them.
- SaveFolder = "C:\temp\outlook_attachments"
- Attachments_log = "C:\temp\log"
- ZipDir = "C:\temp\ZipDir"
- If Dir(SaveFolder, vbDirectory) = Empty Then MkDir (SaveFolder)
- If Dir(ZipDir, vbDirectory) = Empty Then MkDir (ZipDir)
- If Dir(Attachments_log, vbDirectory) = Empty Then MkDir (Attachments_log)
- If Item.Attachments.Count <> 0 Then
- Dim ZipFilename As String
- Select Case Item.Attachments.Count
- Case 1
- ZipFilename = Replace(Item.Attachments.Item(1).DisplayName, " ", "_") & ".zip"
- Case Else
- ZipFilename = "Attachments.zip"
- End Select
-
- 'Save original attachments to $SaveFolder.
- For i = 1 To Item.Attachments.Count
- Item.Attachments.Item(i).SaveAsFile SaveFolder & Item.Attachments.Item(i).DisplayName
- Next
-
- 'Remove original attachments.
- Do While Item.Attachments.Count > 0
- Item.Attachments.Remove 1
- Loop
- End If
- DirZipFilename = ZipDir & ZipFilename
- 'msgbox ZipFilename
- My_PW = GeneratePW()
- MyStr = "C:\Program Files\7-Zip\7z a" & " " & DirZipFilename & " -p" & My_PW & " " & SaveFolder & "*"
- 'msgbox MyStr
- Shell MyStr
- 'Wait until zip file is created.
- Do Until Dir(DirZipFilename, vbNormal) <> vbNullString
- WaitASec
- Loop
- Item.Attachments.Add (DirZipFilename)
- 'write log
- My_Log = Now() & vbTab & GetDirFiles(SaveFolder) & vbTab & GetDirFiles(ZipDir) & vbTab & My_PW
- Open "c:\temp\log\Outlook.Attachments.log.txt" For Append As #1
- Write #1, My_Log
- Close #1
- 'delete temp files
- DelAttachments = "cmd.exe /c del /Q " & SaveFolder & "*"
- DelZipFile = "cmd.exe /c del /Q " & ZipDir & "*"
- Shell DelAttachments
- Shell DelZipFile
- Item.Display
- Cancel = True
- PW_Subject = Item.Subject & "(Password Notification Mail)"
- PW_Mail_Addresses = ""
- For i = 1 To Item.Recipients.Count
- PW_Mail_Addresses = Item.Recipients.Item(i).Address & ";" & PW_Mail_Addresses
- Next
- Call CreatePWMail(PW_Mail_Addresses, My_PW, PW_Subject) '这个地方会报错
- Exit Sub
- Err:
- MsgBox "Error: Something is wrong."
- Cancel = True
- End Sub
- Public Function GetDirFiles(MyGetDir)
- Set fs = CreateObject("Scripting.FileSystemObject")
- Set f = fs.GetFolder(MyGetDir)
- Set flist = f.Files
- For Each i In flist
- MyFileList = i & ", " & MyFileList
- Next
- GetDirFiles = MyFileList
- End Function
- Public Function GeneratePW()
- Dim str As String
- Do Until Len(str) = 8
- i = Int((75 * Rnd) + 48)
- Select Case i
- Case 48 To 57, 65 To 90, 97 To 122
- str = str & Chr(i)
- End Select
- Loop
-
- GeneratePW = str
- End Function
- Public Function WaitASec()
- Savetime = Timer
- While Timer < Savetime + 1
- DoEvents
- Wend
- End Function
- Public Sub CreatePWMail(MailAddess As String, MyPassword As String, MySubject As String)
- Set objOL = CreateObject("Outlook.Application")
- Set itmNewMail = objOL.CreateItem(olMailItem)
- With itmNewMail
- .Subject = MySubject
- .BCC = MailAddess
- .Body = MyPassword
- .Display
- End With
- End Sub
"WordMail不能启动" <- 报这个错误.
|
-
报错
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2012-11-20 10:19
发表于 2012-11-20 14:39
楼主
