[分享]自动发送邮件避免Outlook的安全提示方法之二-Redemption

Long_III

原题目[分享]自动获取外网IP发送到指定邮箱（通过路由器）改为自动发送邮件避免Outlook的安全提示方法之二-Redemption，代码在7楼。

现在做公司的兼职网管，经常想在家控制办公室的服务器，但是又没有现成的软件，只好自己想办法了。大致情况描述如下：

电信ADSL 通过路由器访问网络（外网IP会不住的变动）；服务器设置固定IP 192.168.10.202，开启远程访问功能；在路由器上设置DMZ区域为此IP地址192.168.10.202

本来用的花生壳来实现的，在路由器的DDNS中设置免费域名等，然后用花生壳软件取得此路由器的外网IP，然后远程控制，但是经常发现链接失败的情况，特别在家没办法控制的时候，很是郁闷。

后来只好试用Excel来处理，思路大致为：每隔半小时，取得路由器的外网IP地址，新建邮件并发送到指定邮箱。（条件为需设置好Outlook，并且为路由器的管理员）

代码取自原先一些朋友的，这里仅供大家参考（需引用，打开VBE，工具》引用，Microsoft XML 6.0），

Dim Old_time As Double

Sub hjs() '访问路由器，取得目前状态的IP地址
    Dim httpRequest As MSXML2.XMLHTTP30
    Dim s$, s1$, m%, n%
    Set httpRequest = New MSXML2.XMLHTTP30
    On Error Resume Next
    Application.ScreenUpdating = False
    httpRequest.Open "GET", "http://192.168.10.10/Status_Router.asp", False, "路由器用户名", "密码" '根据情况自己修改
    httpRequest.send ""
    s = httpRequest.responseText
    m = InStr(1, s, "var wan_ip =")
    n = InStr(m, s, ";")
    s1 = Mid(s, m, n - m)
    s2 = Split(s1, """")(1) '根据字符串的规律，取出具体的IP值
    Set httpRequest = Nothing
    SendMail "hjsong_8116@163.com", "IP:=" & s2 & Format(Date, " yyyy-mm-dd"), "Jinsong, FYI"
    Old_time = Now + TimeSerial(0, 0, 30) '这里设置的30秒发一次，是为了做测试用，自己根据实际情况修改
    Application.OnTime Old_time, "sheet1.hjs"
    Application.ScreenUpdating = False
End Sub

Sub SendMail(Email_Address$, Subject$, Body$) '发送邮件（收件人，标题，内容）
    Dim objOL As Object
    Dim itmNewMail As Object

    Set objOL = CreateObject("Outlook.Application")
    Set itmNewMail = objOL.CreateItem(olMailItem)
    With itmNewMail
        .Subject = Subject
        .Body = Body
        .To = Email_Address
    End With
    On Error GoTo continue
SendEmail:
    itmNewMail.display
    DoEvents
    DoEvents
    DoEvents
    SendKeys "%s", Wait:=True '打开Outlook新建的邮件，点击Alt+s发送 【第一种：采用发送键盘的按键方式Alt+S】
    DoEvents
    itmNewMail.display
    GoTo SendEmail '循环判断，直到新建的邮件被发送出去
continue:
    On Error GoTo 0
    Set objOL = Nothing
    Set itmNewMail = Nothing
End Sub

Private Sub CommandButton1_Click() '开始程序的运行
    Sheet1.hjs
End Sub

Private Sub CommandButton2_Click() '取消程序的运行
    On Error Resume Next
    Application.OnTime Old_time, "sheet1.hjs", , False
    MsgBox "OK, Stop."
End Sub

由于我知道自己路由器的密码等，所以直接取的它的密码。应该也可以去某个查询外网IP的网址取出自己的IP地址，我没试验，有兴趣的朋友看看。

有什么好的方式请告诉我，我可是不希望Excel成天干活的哦，谢谢！

[此贴子已经被作者于2008-7-29 13:31:31编辑过]

yuanhongly

去下载天联VPN   很好用。

dxy27

学习了

Long_III

天联VPN是收费的，还是算了。

关于这个程序，还是出现了问题。服务器没有插键盘、鼠标、显示器等，我每次登陆也是局域网内的远程控制，如果我开启链接进去之后，代码可以运行，而关闭链接之后，则不会收到邮件。

代码SendKeys "%s", Wait:=True '打开Outlook新建的邮件，点击Alt+s发送

而服务器本身没有键盘，则这样的操作无效，导致邮件不能发送？谁来研究下，谢谢！

[此贴子已经被作者于2008-7-25 15:32:11编辑过]

3m-cat

不错不错

taller

龙兄试试VNC(Virtual Network Computing）以前是免费软件，不知道现在是否仍然免费

Long_III

通过Outlook的复制品来直接send邮件，避免安全信息提示。需安装Redemption.dll，并在excel VBE中引用它（下载地址http://www.dimastr.com/redemption/，我下载的是第一个Download Developer version）

发送邮件代码如下：（先新建邮件，保存在草稿箱中，然后用复制品替代草稿箱中的文件，发送）

Sub SendMail(Email_Address$, Subject$, Body$, Attachment$) '发送邮件（收件人，标题，内容，附件）
    Dim ObjOL As Object, itmNewMail As Object, itmNewMail_Copy As Object
    Dim olNS As Object, dfrFdr As Object
   
    Set ObjOL = CreateObject("Outlook.Application")
    Set itmNewMail = ObjOL.CreateItem(olMailItem)
    Set itmNewMail_Copy = CreateObject("Redemption.SafeMailItem")
    Set olNS = ObjOL.GetNameSpace("MAPI") '获取Namespace
    Set dftFdr = olNS.GetDefaultFolder(16) '获取草稿箱接口
       
    With itmNewMail
        .Subject = Subject
        .Body = Body
        .To = Email_Address
        '.Attachments.Add Attachment
        .Save
    End With
       
    For I = 1 To dftFdr.Items.Count '遍历文件夹下面的所有Item，把草稿箱里的文件直接发送
        itmNewMail_Copy.Item = dftFdr.Items.Item(I)
        If InStr(1, itmNewMail.Subject, "IP:=") > 0 Then
            itmNewMail_Copy.send '【第二种，采用Outlook的复制品方式】
        End If
    Next
       
    Set ObjOL = Nothing
    Set itmNewMail = Nothing
    Set itmNewMail_Copy = Nothing
    Set olNS = Nothing
    Set dfrFdr = Nothing
End Sub

建议有兴趣的朋友帮忙测试下，然后反馈你们的信息，谢谢！

[此贴子已经被作者于2008-7-29 13:32:36编辑过]

Long_III

由于所有的代码都可以不通过Excel，故最终把代码放到了Outlook里执行，对于Ontime在outlook里不能运行，故采用了API函数settimer来处理，参考，

（同样在Outlook里应引用XML6.0和Redemption)

Thisoutlooksession里代码：

Private Sub Application_Startup()
    hjs
    MsgBox "OK, Run.    -Long_III"
End Sub

Private Sub Application_Quit()
    Stop_hjs
End Sub

模块里代码：

Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElaspe As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Dim TID
Const SendTime As Double = 30 '设置发送邮件的间隔时间，这里以30分钟发一次为例

Sub hjs() '访问路由器，取得目前状态的IP地址
    Dim httpRequest As MSXML2.XMLHTTP30
    Dim s$, s1$, m%, n%
    Set httpRequest = New MSXML2.XMLHTTP30

    httpRequest.Open "GET", "http://192.168.10.10/Status_Router.asp", False, "Admin", "xxxxxx"
    httpRequest.Send ""
    s = httpRequest.responseText
    m = InStr(1, s, "var wan_ip =")
    n = InStr(m, s, ";")
    s1 = Mid(s, m, n - m)
    s2 = Split(s1, """")(1) '根据字符串的规律，取出具体的IP值
    Set httpRequest = Nothing

    SendMail "hjsong_8116@163.com", "IP:=" & s2 & Format(Date, " yyyy-mm-dd"), "Jinsong, FYI", ""

     KillTimer 0, TID
    TID = SetTimer(0, 0, SendTime * 60 * 1000, AddressOf hjs) '到时间重复执行此程序
End Sub

Sub SendMail(Email_Address$, Subject$, Body$, Attachment$) '发送邮件（收件人，标题，内容，附件）
    Dim ObjOL As Object, itmNewMail As Object, itmNewMail_Copy As Object
    Dim olNS As Object, dfrFdr As Object
   
    Set ObjOL = CreateObject("Outlook.Application")
    Set itmNewMail = ObjOL.CreateItem(olMailItem)
    Set itmNewMail_Copy = CreateObject("Redemption.SafeMailItem")
    Set olNS = ObjOL.GetNamespace("MAPI") '获取Namespace
    Set dftFdr = olNS.GetDefaultFolder(16) '获取草稿箱接口
    With itmNewMail
        .Subject = Subject
        .Body = Body
        .To = Email_Address
        .Save
    End With
    For I = 1 To dftFdr.Items.Count '遍历文件夹下面的所有Item，把草稿箱里的文件直接发送
        itmNewMail_Copy.Item = dftFdr.Items.Item(I)
        If InStr(1, itmNewMail.Subject, "IP:=") > 0 Then
            itmNewMail_Copy.Send
        End If
    Next
    Set ObjOL = Nothing
    Set itmNewMail = Nothing
    Set itmNewMail_Copy = Nothing
    Set olNS = Nothing
    Set dfrFdr = Nothing
End Sub

Sub Stop_hjs() '取消程序的运行
    KillTimer 0, TID
    MsgBox "OK, Stop.   -Long_III"
End Sub

所有代码来源于网络，仅供学习使用。

[此贴子已经被作者于2008-7-29 18:33:02编辑过]

y3231057

学习了，谢谢分享！

Long_III

继续测试中……

之前发现代码settimer之后程序运行时最好能KillTimer之后然后再用set，否则会出现同时发送多封邮件的情况。

现在的代码在每分钟发送的情况先正常运行（连续9封都是隔一分钟一次）。