base.bas

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

Attribute VB_Name = "Base"
Option Explicit
Type HtmTra
  strChar As String
  lngPos As Long
End Type




Public Function ReadArea(StrFile As String, PosE As Long) As HtmTra
    Dim strArea As String   '区域块
    Dim AreaPosS As Long    '区域起点
    Dim AreaPosE As Long    '区域终点
    
    AreaPosS = InStr(PosE, StrFile, ">参保人报销地区：")


        If InStr(AreaPosS, StrFile, "bgcolor='#dddddd'>") = 0 Then
           AreaPosE = InStr(AreaPosS, StrFile, "</table>")
        Else
           AreaPosE = InStr(AreaPosS, StrFile, "bgcolor='#dddddd'>")
        End If
     strArea = Mid(StrFile, AreaPosS, AreaPosE - AreaPosS + 17)
    ReadArea.strChar = strArea
    ReadArea.lngPos = AreaPosE
End Function



Public Function ReadLine(strArea As String, row As Long, PosE As Long) As HtmTra

    Dim strLine As String
    Dim LinePosS As Long
    Dim LinePosE As Long
    
      
    LinePosS = InStr(PosE, strArea, "<td>" & row & "</td>")
    LinePosE = InStr(LinePosS, strArea, "</tr>")
    strLine = Mid(strArea, LinePosS, LinePosE - LinePosS + 5)
    
    ReadLine.strChar = strLine
    ReadLine.lngPos = LinePosE
End Function

Public Function ReadCell(strLine As String, Cols As Integer, PosE As Long) As HtmTra
   Dim strReplace As String
   Dim PosS As Long
   Dim strcell As String
   Dim iCol As Long
       
       strReplace = Trim(strLine)
   
   For iCol = 1 To Cols
     
    PosS = InStr(PosE, strReplace, "<td>")
    PosE = InStr(PosS, strReplace, "</td>")
    strcell = Mid(strReplace, PosS, PosE - PosS + 5)
        Do While InStr(1, strcell, "<") <> 0
           strcell = RepHtmFlg(Trim(strcell))
        Loop
   If iCol < 9 Then
    ReadCell.strChar = ReadCell.strChar & ",'" & Replace(Trim(Replace(strcell, vbTab, "")), vbCrLf, "") & "'"
  
   Else
    ReadCell.strChar = ReadCell.strChar & "," & Trim(Replace(strcell, vbTab, ""))
   End If
  Next
   ReadCell.lngPos = PosE
   
End Function

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

Public Function GetFileName(strPathFile As String) As String
    Dim i As Long
    Dim StrFile As String
    
    For i = Len(strPathFile) To 1 Step -1
        If Mid(strPathFile, i, 1) = "\" Then
            StrFile = Right(strPathFile, Len(strPathFile) - i)
            Exit For
        End If
    Next
    For i = Len(StrFile) To 1 Step -1
        If Mid(StrFile, i, 1) = "." Then
            GetFileName = Left(StrFile, i - 1)
            Exit Function
        End If
    Next
    
    
End Function