水如烟

                 顺其自然,水到渠成 LzmTW

文或代码皆是面向初学者.我是爱好者,也是初学者.那些"文章",只按自己理解写,我是不知术语名词的.所以只供参考,也仅供参考.

导航

HOW TO:利用Excel的QueryTable下载网上数据

Posted on 2006-09-16 18:53  水如烟(LzmTW)  阅读(754)  评论(0编辑  收藏  举报
Author:水如烟

这里所说的网上数据,是基于:
一、有固定网址发布最新数据的链接;
二、数据格式固定。

在去年的10月,曾写了个《全国县及县以上行政区划代码信息类 》
见:http://www.cnblogs.com/LzmTW/archive/2005/10/22/260066.html

现在仍以行政区划代码数据为例。

行政区划代码数据由国家统计局发布,网址为
http://www.stats.gov.cn/tjbz/xzqhdm/index.htm
数据格式是固定的:
如最新的为2005年12月31日
http://www.stats.gov.cn/tjbz/xzqhdm/t20041022_402301029.htm
最旧的为2001年10月的,
http://www.stats.gov.cn/tjbz/xzqhdm/t20021125_46781.htm

但是有例外,这在代码中说。

方案组织:
效果:


以下为代码:
NetConst.vb
Namespace NET
    
Public Class NetConst
        
Private Sub New()
        
End Sub

        
Public Const GOV_DEFAULT As String = "www.stats.gov.cn"
        
Public Const GOV_ADDRESS As String = "http://www.stats.gov.cn/tjbz/xzqhdm/"
        
Public Const WEBTABLE_INDEX As String = "9"
    
End Class
End Namespace
NetInformation.vb
Imports System.Net
Imports System.IO
Imports System.Text.RegularExpressions

Namespace NET
    
Public Class NetInformation
        
Private gNetUpdateInformations(-1As NetUpdateInformationItem


        
Public ReadOnly Property UpdateInformationsTable() As DataTable
            
Get
                
Return GetUpdateInformationsTable()
            
End Get
        
End Property

        
Private Function GetUpdateInformationsTable() As DataTable
            
Dim mDataTable As New DataTable("UpdateInformations")
            
With mDataTable
                .Columns.Add(
"Address")
                .Columns.Add(
"LastDate")
                
For Each item As NetUpdateInformationItem In gNetUpdateInformations
                    .Rows.Add(
New String() {item.Address, item.LastDate})
                
Next
                .AcceptChanges()
            
End With
            
Return mDataTable
        
End Function

        
Public Sub DownloadInformationsFromNet()

            
Dim mRegex As New Regex("(?<date>2.*日)")

            
Dim mNetUpdateItems As NetUpdateItem() = GetNetUpdateItems()
            
Dim mNetUpdateInformationItem As NetUpdateInformationItem

            
Dim tmp As NetUpdateItem
            
'由于后两个不合规则,舍去不用。最后一个没有日期,倒数第二个提供的是附件数据。
            For i As Integer = 0 To mNetUpdateItems.Length - 1 - 2
                tmp 
= mNetUpdateItems(i)

                mNetUpdateInformationItem 
= New NetUpdateInformationItem
                
With mNetUpdateInformationItem
                    .Address 
= tmp.Address
                    .LastDate 
= CType(mRegex.Match(tmp.Content).Value, Date).ToString("yyyyMMdd")
                
End With

                AppendItem(Of NetUpdateInformationItem)(mNetUpdateInformationItem, gNetUpdateInformations)
            
Next
        
End Sub

        
Private Function GetNetUpdateItems() As NetUpdateItem()

            
Dim mResult(-1As NetUpdateItem

            
Dim mRegex As New Regex("<a href='(?<href>.*)' target='_blank' >(?<content>.*行政区划代码.*)</a>")
            
Dim mCollection As MatchCollection

            
Dim mClient As New WebClient()

            
Dim mStream As Stream = mClient.OpenRead(NetConst.GOV_ADDRESS)
            
Dim mReader As New StreamReader(mStream, System.Text.Encoding.Default)
            
Dim mText As String = mReader.ReadToEnd

            mReader.Close()
            mStream.Close()
            mClient.Dispose()

            mCollection 
= mRegex.Matches(mText)

            
Dim tmpItem As NetUpdateItem
            
For Each m As Match In mCollection
                tmpItem 
= New NetUpdateItem
                
With tmpItem
                    .Address 
= NetConst.GOV_ADDRESS & m.Groups(1).Value
                    .Content 
= m.Groups(2).Value
                
End With

                AppendItem(Of NetUpdateItem)(tmpItem, mResult)
            
Next

            
Return mResult
        
End Function

        
Private Structure NetUpdateItem
            
Public Address As String
            
Public Content As String
        
End Structure

        
Private Structure NetUpdateInformationItem
            
Public Address As String
            
Public LastDate As String
        
End Structure

        
Private Sub AppendItem(Of T)(ByVal value As T, ByRef array As T())
            
ReDim Preserve array(array.Length)
            array(array.Length 
- 1= value
        
End Sub

    
End Class

End Namespace

ExcelQueryTable.vb
Option Strict Off

Namespace NET
    
Public Class ExcelQueryTable
        
Private gExcelApplication As Object
        
Private gWorkbook As Object
        
Private gWorksheet As Object
        
Private gQueryTable As Object

        
Sub New()
            Initialize()
        
End Sub

        
Private Sub Initialize()
            gExcelApplication 
= CreateObject("Excel.Application")
            gExcelApplication.DisplayAlerts 
= False '使退出时不询问是否存盘
            gWorkbook = gExcelApplication.Workbooks.Add
            gWorksheet 
= gWorkbook.Worksheets.Add
        
End Sub

        
'这里只作简单处理,详细处理在我的BLOG上有相关“文章”作过介绍
        Public Sub Close()
            gWorkbook.Close()
            gWorksheet 
= Nothing
            gWorkbook 
= Nothing
            gExcelApplication.DisplayAlerts 
= True
            gExcelApplication.Quit()
            gExcelApplication 
= Nothing
        
End Sub

        
Public Function Query(ByVal address As StringAs DataTable
            
Dim mDataTable As DataTable = GetDataTable()

            gWorksheet.Cells.Clear()

            gQueryTable 
= gWorksheet.QueryTables.Add( _
                Connection:
=String.Format("URL;{0}", address), _
                Destination:
=gWorksheet.Range("A1"))

            
With gQueryTable
                .WebTables 
= NetConst.WEBTABLE_INDEX  '这是固定的
                .Refresh(BackgroundQuery:=False)
            
End With


            
Dim mCell As Object
            
Dim mMaxRowIndex As Integer
            
Dim line As Object

            mMaxRowIndex 
= gWorksheet.Cells.SpecialCells(11).Row 'Excel.XlCellType.xlCellTypeLastCell=11
            mCell = gWorksheet.Range("A1")

            
For i As Integer = 0 To mMaxRowIndex
                line 
= mCell.Offset(i, 0).Value
                
If line IsNot Nothing Then
                    AddRow(mDataTable, line.ToString)
                
End If
            
Next

            gQueryTable.Delete()
            gQueryTable 
= Nothing

            
Return mDataTable
        
End Function

        
Private Sub AddRow(ByVal table As DataTable, ByVal line As String)
            line 
= line.Trim
            
If line.Length < 7 Then Exit Sub

            
Dim tmpCode As String
            
Dim tmpName As String

            tmpCode 
= line.Substring(06)
            tmpName 
= line.Substring(6).Trim

            
If Not IsNumeric(tmpCode) Then Exit Sub '前六位需是数字

            table.Rows.Add(
New String() {tmpCode, tmpName})
        
End Sub

        
Private Function GetDataTable() As DataTable
            
'表的列名意义为:代码、名称
            Dim mDataTable As New DataTable("RegionalCode")
            
With mDataTable.Columns
                .Add(
"Code")
                .Add(
"Name")
            
End With
            
Return mDataTable
        
End Function

    
End Class
End Namespace

测试代码:
MainForm.vb(界面部分省,在最后有整个方案供下载)
Public Class MainForm
    
Private gNetInformation As New RegionalCodeLibrary.NET.NetInformation
    
Private gQueryTable As RegionalCodeLibrary.NET.ExcelQueryTable


    
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click

        
If Not CheckNetworkIsAvailable() Then Exit Sub

        ShowMessage(
"正在下载数据信息")

        gNetInformation.DownloadInformationsFromNet()
        
With Me.ComboBox1
            .DataSource 
= gNetInformation.UpdateInformationsTable
            .DisplayMember 
= "LastDate"
        
End With

        ShowMessage(
"")
    
End Sub

    
Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
        
If String.IsNullOrEmpty(Me.ComboBox1.Text) Then Exit Sub

        
If Not CheckNetworkIsAvailable() Then Exit Sub

        
If gQueryTable Is Nothing Then

            ShowMessage(
"正在启动Excel")
            gQueryTable 
= New RegionalCodeLibrary.NET.ExcelQueryTable

        
End If

        
Dim mAddress As String = CType(Me.ComboBox1.SelectedItem, DataRowView).Row.Item("Address").ToString

        ShowMessage(
String.Format("正在下载{0}数据"Me.ComboBox1.Text))
        
Me.DataGridView1.DataSource = gQueryTable.Query(mAddress)

        ShowMessage(
String.Format("{0}共有数据{1}项"Me.ComboBox1.Text, Me.DataGridView1.RowCount))
    
End Sub

    
Private Sub Button3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.Click
        ClearEnvironment()
    
End Sub

    
Private Function CheckNetworkIsAvailable() As Boolean
        
Dim mResult As Boolean = False
        mResult 
= My.Computer.Network.IsAvailable

        
If Not mResult Then
            ShowMessage(
"本地连接无效")

        
Else
            
Try
                mResult 
= My.Computer.Network.Ping(RegionalCodeLibrary.NET.NetConst.GOV_DEFAULT)
            
Catch ex As Exception
                mResult 
= False
            
End Try

            
If Not mResult Then
                ShowMessage(
String.Format("本机没有连接Internet或发布网址{0}无效", RegionalCodeLibrary.NET.NetConst.GOV_ADDRESS))
            
End If
        
End If

        
Return mResult
    
End Function

    
Private Sub ShowMessage(ByVal msg As String)
        
If msg = "" Then msg = "待命"
        
Me.Label1.Text = String.Format("消息:{0}", msg)
        
Me.Label1.Refresh()
    
End Sub

    
Private Sub MainForm_FormClosing(ByVal sender As ObjectByVal e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing
        ClearEnvironment()
    
End Sub

    
Private Sub ClearEnvironment()
        
If gQueryTable Is Nothing Then Exit Sub
        gQueryTable.Close()
        gQueryTable 
= Nothing
    
End Sub
End Class

方案下载:代码