字符串提取

Function bTest(ByVal s As String, ByVal p As String) As Boolean
    Dim re As RegExp
    Set re = New RegExp
     re.IgnoreCase = False  '设置是否匹配大小写
     re.Pattern = p
     bTest = re.Test(s)
End Function
Function StrReplace(s As String, p As String, r As String) As String
   
    Dim re As RegExp
    Set re = New RegExp
     re.IgnoreCase = True
     re.Global = True
     re.Pattern = p
     StrReplace = re.Replace(s, r)
End Function
Function getEmail(ByVal s As String)
    Dim re As RegExp
    Dim mh As Match
    Dim mhs As MatchCollection
    Dim temp As String
   
   
    Set re = New RegExp
    re.Global = True
    re.Pattern = "(\w)+[@](\w)+[.](\w)+"
    If re.Test(s) = False Then Exit Function
    Set mhs = re.Execute(s)
    For Each mh In mhs
        'Debug.Print mh.SubMatches(0)
        'Debug.Print mh.Value
        temp = mh.Value + temp
    Next
    getEmail = Trim(temp)
End Function
Function build(ByVal s As String)
    Dim email As String     '字符串
    Dim temp As String
   
    Dim p As String     '正则表达式
    Dim r As String     '要替换的字符串
    email = getEmail(s)
    's = "我的E-mail: [e-mail] 。欢迎致电!"
    'p = "w+@w+.w+"
    'r = "[e-mail]"
    temp = Replace(s, email, ",")
   
    temp = Trim(temp) + "," + email
   
    temp = Replace(temp, vbCrLf, "")
    If temp = "," Then
        'Debug.Print temp
        Exit Function
    End If
    build = Trim(temp)
  
End Function

Private Sub Command1_Click()
     Dim strLine    As String

    Dim strValue() As String
   
    Dim p As String
   
    Dim temp As String
   

    Dim LineCount  As Integer  '行数
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile(App.Path + "\testfile.csv", True)
        
        

    temp = "姓名,email"
    a.WriteLine (temp)
    temp = ""
    p = "(\w)+[@](\w)+[.](\w)+"

    LineCount = 0

    Open App.Path + "\test.txt" For Input As #1

        Do While Not EOF(1)

            LineCount = LineCount + 1

            Line Input #1, strLine

            If LineCount > 2 Then
                              
                If bTest(strLine, p) Then
                 a.WriteLine (Trim(temp + "," + strLine))
                 temp = ""
                Else
                 temp = temp + strLine
                End If
               
               
                'Debug.Print strLine
               
                'strValue = Split(strLine, vbTab, , vbTextCompare)

                '||……

                '||向数据库中增加一条记录，相应字段的值分别为

                '||strValue(0)、strValue(1)、strValue(2)、strValue(3)

                '||……

            End If

        Loop

    Close #1
    a.Close
End Sub

Private Sub Command2_Click()
         Dim strLine    As String

    Dim strValue() As String
   

   
    Dim temp1 As String
   

    Dim LineCount  As Integer  '行数
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile(App.Path + "\testfile.csv", True)
        
        

    temp1 = "姓名,手机,email"
    a.WriteLine (temp1)
    temp1 = ""
  

    LineCount = 0

    Open App.Path + "\163txt.txt" For Input As #1

        Do While Not EOF(1)

            LineCount = LineCount + 1

            Line Input #1, strLine

            If LineCount > 2 Then
                              
              temp1 = build(strLine)
              If temp1 = "" Then
              Else
              a.WriteLine (temp1)
              End If

            End If

        Loop

    Close #1
    a.Close
End Sub