form1.frm

将北京首领医保网页数据自动转换到数据库中

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   7755
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   12585
   LinkTopic       =   "Form1"
   ScaleHeight     =   7755
   ScaleWidth      =   12585
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox TxtArea 
      Height          =   1815
      Left            =   360
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   7
      Top             =   2760
      Width           =   10215
   End
   Begin VB.CommandButton CmdArea 
      Caption         =   "读取区域"
      Height          =   495
      Left            =   10920
      TabIndex        =   6
      Top             =   1560
      Width           =   1335
   End
   Begin MSComDlg.CommonDialog ComDlg 
      Left            =   11760
      Top             =   6960
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      Filter          =   "*.htm|*.htm"
   End
   Begin VB.TextBox TxtCell 
      Height          =   855
      Left            =   360
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   5
      Top             =   6720
      Width           =   10215
   End
   Begin VB.TextBox TxtLine 
      Height          =   1935
      Left            =   360
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   4
      Top             =   4680
      Width           =   10215
   End
   Begin VB.CommandButton CmdReadCell 
      Caption         =   "读取一格"
      Height          =   495
      Left            =   10920
      TabIndex        =   3
      Top             =   3000
      Width           =   1335
   End
   Begin VB.TextBox TxtFile 
      Height          =   2415
      Left            =   360
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   2
      Top             =   240
      Width           =   10215
   End
   Begin VB.CommandButton CmdReadLine 
      Caption         =   "读取表格一行"
      Height          =   495
      Left            =   10920
      TabIndex        =   1
      Top             =   2280
      Width           =   1335
   End
   Begin VB.CommandButton CmdOpen 
      Caption         =   "读取网页"
      Height          =   495
      Left            =   10920
      TabIndex        =   0
      Top             =   840
      Width           =   1335
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
    Dim strArea As String   '区域块
    Dim AreaPosS As Long    '区域起点
    Dim AreaPosE As Long    '区域终点
    Dim strcell As String   '单元格字串
    Dim CellPosS As Long    '单元格起点
    Dim CellPosE As Long    '单元格终点
    Dim PosS As Long        '起点
    Dim PosE As Long        '终点
    Dim strReplace As String    '替换字串
    Dim iCols As Long           '总列数
    Dim iFileFlag As Integer    '文件标志

Private Sub CmdArea_Click()
    i = 1
    AreaPosE = 1


    Do While InStr(AreaPosE, TxtFile.Text, ">参保人报销地区：") <> 0
        AreaPosS = InStr(AreaPosE, TxtFile.Text, ">参保人报销地区：")
        If InStr(AreaPosS, TxtFile.Text, "bgcolor='#dddddd'>") = 0 Then
            AreaPosE = InStr(AreaPosS, TxtFile.Text, "</table>")
        Else
            AreaPosE = InStr(AreaPosS, TxtFile.Text, "bgcolor='#dddddd'>")
        End If
        strArea = Mid(TxtFile.Text, AreaPosS, AreaPosE - AreaPosS + 5)
    
        TxtArea = TxtArea & vbCrLf & strArea
        i = i + 1
    Loop
End Sub

Private Sub CmdOpen_Click()
   ComDlg.ShowOpen
   
   Fname = ComDlg.FileName
   If Fname <> "" Then
     TxtFile.Text = ""
    Open Fname For Input As #1
    b = ""
    Do Until EOF(1)
        Line Input #1, NextLine
     b = b & NextLine & vbCrLf
    Loop
    Close #1
    TxtFile.Text = b
End If
   
End Sub

Private Sub CmdReadCell_Click()
     LinePosE = 1
    strReplace = Trim(TxtLine.Text)
    TxtCell = ""
   For iCols = 1 To 15
     
    LinePosS = InStr(LinePosE, strReplace, "<td>")
    LinePosE = InStr(LinePosS, strReplace, "</td>")
    strcell = Mid(strReplace, LinePosS, LinePosE - LinePosS + 5)
        Do While InStr(1, strcell, "<") <> 0
           strcell = RepHtmFlg(Trim(strcell))
        Loop
   TxtCell = TxtCell & vbTab & Trim(Replace(strcell, vbTab, ""))
  Next
  
End Sub



Private Sub CmdReadLine_Click()
    Dim strLine As String
    Dim LinePosS As Long
    Dim LinePosE As Long
    i = 1
    LinePosE = 1
    Do While InStr(LinePosE, strArea, "<td>" & i & "</td>") <> 0
        LinePosS = InStr(LinePosE, strArea, "<td>" & i & "</td>")
        LinePosE = InStr(LinePosS, strArea, "</tr>")
        strLine = Mid(strArea, LinePosS, LinePosE - LinePosS + 5)
    
        TxtLine = TxtLine & vbCrLf & strLine
        i = i + 1
     Loop
    
End Sub

Public Function RepHtmFlg(HtmLine As String) As String
  Dim iPosS As Integer
  Dim iPosE As Integer
  Dim strRep As String
  
    iPosS = InStr(1, HtmLine, "<")
    iPosE = InStr(iPosS, HtmLine, ">")
    strRep = Mid(HtmLine, iPosS, iPosE - iPosS + 1)
    
     RepHtmFlg = Replace(HtmLine, strRep, "")

End Function