ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 17401|回复: 22

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2008-7-25 13:43 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:邮件应用开发

原题目[分享]自动获取外网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编辑过]

TA的精华主题

TA的得分主题

发表于 2008-7-25 14:00 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2008-7-25 14:32 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2008-7-25 15:31 | 显示全部楼层

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

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

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

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

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

TA的精华主题

TA的得分主题

发表于 2008-7-27 01:04 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2008-7-27 05:43 | 显示全部楼层

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2008-7-29 11:46 | 显示全部楼层

通过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编辑过]

TA的精华主题

TA的得分主题

 楼主| 发表于 2008-7-29 15:38 | 显示全部楼层

由于所有的代码都可以不通过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 "use*****" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElaspe As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "use*****" (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编辑过]

TA的精华主题

TA的得分主题

发表于 2008-7-29 15:50 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2008-7-29 18:36 | 显示全部楼层

继续测试中……

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

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

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-7-20 21:37 , Processed in 0.341437 second(s), 16 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表