用EXCEL自动查询并保存网络天气预报记录

     工程施工受天气影响较大，因此工程施工管理人员必需提前掌握天气情况。而且，在工程施工记录中，详实准确的天气情况记录也是一项重要内容。

       现在，人们通过网络可以随时了解到未来一定时间内的比较准确的天气情况，但是，要把这些信息作为天气情况保存为天气历史记录，往往是通过手工复制的方式完成，因此非常地不太方便。

　　那么，能不能通过一定方式，实现自动地获取网络天气预报信息、而且自动地保存这些天气预报信息呢？

　　为便于以后利用这些天气历史记录，我希望能把它们保存在EXCEL电子表格中，因此，我尝试用EXCEL来实现这一目标。

　　首先，我选定中国天气网的网页作为网络天气预报的信息来源，开始尝试。

　　在第1次尝试时，我用EXCEL打开了网页，但是立即发现，该文件为只读格式，不能保存数据。不能成功。

　　第2次尝试，换一个思路，从EXCEL导入Web数据查询，输入网址后，导入成功，发现可以保存表格，而且可以刷新，我非常高兴：有了这两个保障作为基础，离成功就不远了。

　　接下来，我编辑该EXCEL工作薄的表格中的Web查询属性，使它只提取需要的内容。

　　然后，编写VBA代码，以便将查询到的数据自动保存到该工作薄中另一个工作表中，并设置该代码在工作表发生Web查询刷新后立即自动执行。经调试修改，代码可以正常发挥作用，基本上可以达到目的了。

　　但是，接下来，事情并没有那么快就彻底解决。

　　这是因为，要做到自动查询Web数据、自动保存数据到其它位置，就必须使EXCEL能自动刷新Web数据查询，同时EXCEL还要能自动执行VBA代码，但是，处于安全性的考虑，我通常都是把宏安全性设为“中”级以上的，这样每当在执行这个任务时，就需要先手动修改宏安全性为低，然后重新打开EXCEL，手动刷新Web数据并保存，接下来还要再次手动把EXCEL宏安全性恢复为“中”级以上，因此并不能完全免除手动操作，甚至比手工从网页上复制信息并粘贴到EXCEL表格中保存还要更烦琐。

　　那么，能不能通过某种方法，实现在打开EXCEL表格前自动降低宏安全性，而在EXCEL完成自动查询保存后，又能自动调高宏安全性呢？

　　我了解，EXCEL宏安全性等级和自动刷新Web数据查询安全性等级，都是由注册表项中的参数设置控制的，而批处理程序能够做到修改注册表和启动其它程序如EXCEL等，而EXCEL在启用宏后，也可以通过VBA代码修改注册表以及进行文件操作。因此，对于上面的两个问题，理论上来说是可以解决的。

　　接下来，我搜索了宏安全性和启用自动刷新的注册表项和其安全性等级对应的值，又分别找来Windows批处理程序和VBA代码修改注册表的示例文件，建立了一个批处理程序和一个EXCEL工作薄，经过反复调试修改，最终解决了这两个问题，达到了用EXCEL自动查询网络天气预报并自动保存的目的。要查看详情，或者要下载源表格的，请见：http://club.excelhome.net/thread-652007-1-1.html

文件中的代码如下：

　　文件一：EXCEL自动查询并保存网络天气预报记录.cmd

echo off
REG ADD HKCU\Software\Microsoft\Office\11.0\Excel\Options /v QuerySecurity /t Reg_dword /d 00000002 /f
REG ADD HKCU\Software\Microsoft\Office\11.0\Excel\Security /v Level /t Reg_dword /d 00000001 /f
start 用EXCEL自动查询并保存网络天气预报记录.xls
exit

　　文件二：EXCEL自动查询并保存网络天气预报记录.xls

Private Sub Worksheet_Change(ByVal Target As Range)
    cc1 = Sheet1.[IV1].End(xlToLeft).Column
    rr1 = Sheet1.Cells(65536, cc1).End(xlUp).Row
    rr2 = Sheet2.Cells(65536, cc1 + 1).End(xlUp).Row
    Sheet2.Range(Sheet2.Cells(rr2 + 1, 2), Sheet2.Cells(rr2 + rr1, cc1 + 1)) = Sheet1.Range(Cells(1, 1), Cells(rr1, cc1)).Value
        '复制天气情况到表2，从第2列开始写入
    Sheet2.Range(Sheet2.Cells(rr2 + 1, 1), Sheet2.Cells(rr2 + rr1, 1)) = Now '对表2中新增加的天气情况添加记录日期
   
    Sheet2.Select
    Sheet2.Cells(rr2 + rr1, 1).Select
    ThisWorkbook.Save
    Call SetExcelVBA '调用宏，提高宏安全等级以及自动刷新外部数据的安全等级。
    MsgBox ("已保存天气预报记录，点确定将退出EXCEL！")
    Application.OnTime Now + TimeValue("00:00:01"), "Sheet1.ExcelQuit" '延时运行一个程序，本例为退出EXCEL
End Sub

Sub SetExcelVBA() '练习：改变Excel的宏安全级别和自动刷新外部数据的安全级别

'使用：Wscript，FileSystemObject，创建txt文件，注册表操作，VBS文件自我删除，改变Excel文件读写属性等
'By

Dim WSH As Object, ret1, ret2 As String, regStr1, regStr2 As String
Dim strFullname As String, strVBS As String
Dim tf, fso, RetVal

'本程序仅适用于Excel 2003( 11.0)，如果当前版本不是2003则退出
If Application.Version <> "11.0" Then MsgBox "本代码仅在 Excel 2003 下可使用! ", vbOKOnly + vbCritical, "Keanjeason": Exit Sub
strFullname = ThisWorkbook.FullName '取得当前工作薄的全名
strVBS = Replace(UCase(strFullname), ".XLS", ".vbs") 'temp文件VBS的文件名
Set WSH = CreateObject("Wscript.Shell") '创建Wscript对象
Err.Clear
On Error Resume Next
regStr1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Excel\Security\Level" '注册表中Excel vba宏安全级别位置
ret1 = WSH.RegRead(regStr1) '读取当前宏安全级别
If Err.Number <> 0 Then
      '判断读取是否成功
      MsgBox "从注册表读取当前Excel VBA安全级别设置失败，本程序将退出! ", vbOKOnly + vbCritical, "Keanjeason"
      Exit Sub
Else
   '如果当前Excel VBA安全级别不为“中”,则设置为“中”,值1-4分别对应：低，中，高，非常高
   If Val(ret1) <> 2 Then ret1 = WSH.RegWrite(regStr1, "2", "REG_DWORD")
End If

regStr2 = "HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Excel\Options\QuerySecurity" '注册表启动自动刷新外部数据的安全级别位置
ret2 = WSH.RegRead(regStr2) '读取当前自动刷新外部数据的安全级别
If Err.Number <> 0 Then
      '判断读取是否成功
      MsgBox "从注册表读取当前Excel启动自动刷新外部数据的安全级别设置失败，本程序将退出! ", vbOKOnly + vbCritical, "Keanjeason"
      Exit Sub
Else
   '如果当前Excel 启动自动刷新外部数据的安全级别不为“启动”,则设置为“启动”,值0-2分别对应：中级，按提示设定；高，禁止启动且不提示；低，启动且不提示
   If Val(ret2) <> 0 Then ret2 = WSH.RegWrite(regStr2, "0", "REG_DWORD")
End If

Set fso = CreateObject("Scripting.FileSystemObject")
Set tf = fso.CreateTextFile(strVBS, True) '创建temp文件VBS文件

With tf
     '写入VBS文件内容
     .WriteLine ("Dim oExcel,fso,delme")
     .WriteLine ("Set fso = CreateObject(""Scripting.FileSystemObject"")")
     '.WriteLine ("Set oExcel = CreateObject(""excel.application"")")
     '.WriteLine ("oExcel.Workbooks.Open " & Chr(34) & strFullname & Chr(34))
     '.WriteLine ("oExcel.Visible=true")
     '.WriteLine ("Set oExcel = Nothing")
     .WriteLine ("delme = fso.DeleteFile(" & Chr(34) & strVBS & Chr(34) & ")")
     .Close
End With

'With ThisWorkbook
     '将当前文件属性设置为“只读”，以方便重新打开
     '.ChangeFileAccess Mode:=xlReadOnly
     '.Saved = True
'End With

RetVal = WSH.Run(Chr(34) & strVBS & Chr(34), 1, True) '运行刚刚创建的VBS文件，新启动一个Excel程序

Application.Quit '退出当前Excel
Set WSH = Nothing
Set fso = Nothing

End Sub

Sub ExcelQuit()
    Application.Quit
End Sub

 

【2011-9-14更新】

更新内容：1、使用VBS脚本文件替代cmd批处理文件，避免显现难看的cmd窗口。2、用程序自动判断EXCEL版本号，对应处理其注册表项，使程序能够适应任意版本的EXCEL。3、修正代码中的局部不足之处，现在，您可以用办公助手之类的第3方程序来启动它（我用的是ShirusuPad，一款非常优秀的桌面便笺软件，小巧而且功能强大，定时启动天气查询，方便无比！），而再也不会出现找不到工作薄的情况！

下面介绍，如何修改表格中原来的天气预报城市（区县），或者说如何达到“自定义”查询目的：

以下内容转自本人在EXCEL HOME论坛的原创贴：

【初次使用时的注意事项】：“关于修改想要查询天气的城市方法的具体操作步骤”，请对照图片操作：
首先，打开解压后的xls文件，不要启用宏！
第1步、激活sheet1工作表，选择其A1单元格，
第2步、从“外部数据”工具栏中，点击“编辑查询”按钮，
第3步、从打开的网页中，转到指定城市（区县）的天气预报网页，
第4步、点击网页中天气预报内容的第1项，即将其勾选上，
第5步、点击对话框右下方的“导入”按钮，
第6步、关闭并保存工作薄。

至此，已经完成了对城市地区的修改。双击同一文件夹下的vbs文件，就可以实现自动查询并保存天气预报了。

 

修改后的文件总数，仍为2个，一个是《用EXCEL自动查询并保存网络天气预报记录.vbs》，另一个是《用EXCEL自动查询并保存网络天气预报记录.xls》

其中的代码，与更新前相比，有了很大程度的精简，具体如下：

其一、《用EXCEL自动查询并保存网络天气预报记录.vbs》：

dim XLApp
dim XLAppVersion
dim WSH
dim Mypath
Dim MyCommand

'获得EXCEL的主版本号
Set XLApp = CreateObject("Excel.Application")
XLAppVersion = XLApp.Version

'根据EXCEL版本号，修改注册表项:
'把宏安全性级别调为“低”，
'把自动刷新外部数据设为启用
Set WSH = CreateObject("Wscript.Shell")
'On Error Resume Next
regStr1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & XLAppVersion & "\Excel\Security\Level"
ret1 = WSH.RegWrite(regStr1, "1", "REG_DWORD")
regStr2 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & XLAppVersion & "\Excel\Options\QuerySecurity"
ret2 = WSH.RegWrite(regStr2, "2", "REG_DWORD")

'获取vbsFile所在路径
with Wscript
Mypath=left(.scriptfullname,len(.scriptfullname)-len(.scriptname))
end with

'调用EXCEL打开指定路径下的工作薄
MyCommand= "excel.exe """&Mypath&"用EXCEL自动查询并保存网络天气预报记录.xls"""
WSH.run MyCommand',0

 

其二、《用EXCEL自动查询并保存网络天气预报记录.xls》：

Private Sub Worksheet_Change(ByVal Target As Range)
    r = Sheet1.[G100].End(3).Row
    arr = Sheet1.Range("A1:G" & r).Value
    Sheet2.Activate
    With Sheet2.[a65536].End(3) '
        .Offset(1, 1).Resize(r, 7) = arr '保存天气情况
        .Offset(1, 0).Resize(r, 1) = Now '添加当前日期时间
        .Activate
    End With
    ThisWorkbook.Save
    Call SetExcelVBA '调用宏，提高宏安全等级以及自动刷新外部数据的安全等级。
    MsgBox ("已保存天气预报记录，点确定将退出EXCEL！")
    Application.Quit
End Sub
Sub SetExcelVBA() '改变Excel的宏安全级别和自动刷新外部数据的安全级别
Dim WSH
GetVersion = Application.Version
Set WSH = CreateObject("Wscript.Shell")
On Error Resume Next
regStr1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & GetVersion & "\Excel\Security\Level"
ret1 = WSH.RegWrite(regStr1, "2", "REG_DWORD") '设置Excel的宏安全级别为“中”级

regStr2 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & GetVersion & "\Excel\Options\QuerySecurity"
ret2 = WSH.RegWrite(regStr2, "0", "REG_DWORD") '设置Excel自动刷新外部数据宏安全级别为“中”级

Set WSH = Nothing

End Sub