vb实现类似xml的字符串的行合并【第二场】

Question

<deliver><mobile>13788888888</mobile><ext>123</ext><content>我真的</content></deliver>
<deliver><mobile>13788888888</mobile><ext>123</ext><content>非常开心</content></deliver>
<deliver><mobile>13788888888</mobile><ext>123</ext><content>，谢谢你</content></deliver>
<deliver><mobile>13477777777</mobile><ext>456</ext><content>和你分手后</content></deliver>
<deliver><mobile>13477777777</mobile><ext>456</ext><content>我很快乐</content></deliver>
<deliver><mobile>13600000000</mobile><ext>789</ext><content>我是终结者</content></deliver>
<deliver><mobile>13600000000</mobile><ext>000</ext><content>别合并我，我是异类</content></deliver>====================    最新版本，符合XML格式 ，转换成  ===============================<deliver><mobile>13788888888</mobile><ext>123</ext><content>我真的非常开心，谢谢你</content></deliver>
<deliver><mobile>13477777777</mobile><ext>456</ext><content>和你分手后我很快乐</content></deliver>
<deliver><mobile>13600000000</mobile><ext>789</ext><content>我是终结者</content></deliver>
<deliver><mobile>13600000000</mobile><ext>000</ext><content>别合并我，我是异类</content></deliver>****************************************** 说明 *************************************
1.只有 mobile 和 ext 一致时，才 [合体]，否则孔雀东南飞
2.条件符合 1 的话，只[合体]相邻的两条，不相邻的不[合体]
3.前后两段都是一行的，为了方便观察，我才回车的
4.第一版本请看 http://topic.csdn.net/u/20100707/16/effd7628-f643-42b7-b820-989665e0e0da.html
5.迫于无奈，诅咒那个叫老板的人。

Answer 1

Private Sub Command1_Click()
   Dim tmp1$, tmp2$, tmp3$, tmp4$, tmp5$, tmp6$, tmp7$, tmp8$
   Dim wz1%, wz2%, wz3%, wz4%, s$, i%
   s = "<deliver><mobile>13788888888</mobile><ext>123< /ext><content>我真的</content></deliver>" & _
       "<deliver><mobile>13788888888</mobile><ext>123< /ext><content>非常开心</content></deliver>" & _
       "<deliver><mobile>13788888888</mobile><ext>123< /ext><content>，谢谢你</content></deliver>" & _
       "<deliver><mobile>13477777777</mobile><ext>456< /ext><content>和你分手后</content></deliver>" & _
       "<deliver><mobile>13477777777</mobile><ext>456< /ext><content>我很快乐</content></deliver>" & _
       "<deliver><mobile>13600000000</mobile><ext>789< /ext><content>我是终结者</content></deliver>" & _
       "<deliver><mobile>13600000000</mobile><ext>000< /ext><content>别合并我，我是异类</content></deliver>"   While s <> ""
       iSplit s, wz1, wz2, wz3, wz4, tmp1, tmp2, tmp3
       tmp7 = Mid(s, 1, wz4)
       s = Mid(s, wz4 + 1)
       If s <> "" Then
          For i = 1 To Len(s)
              
              iSplit s, wz1, wz2, wz3, wz4, tmp4, tmp5, tmp6
              If tmp1 = tmp4 And tmp2 = tmp5 Then
                 tmp3 = tmp3 & tmp6
                 tmp7 = Mid(s, 1, wz4)
                 s = Mid(s, wz4 + 1)
                 If s = "" Then
                    tmp8 = tmp8 & Mid(tmp7, 1, wz3) & tmp3 & Mid(tmp7, InStr(wz3 + 1, tmp7, "<"))
                    Exit For
                 End If
              Else
                 tmp8 = tmp8 & Mid(tmp7, 1, wz3) & tmp3 & Mid(tmp7, InStr(wz3 + 1, tmp7, "<"))
                 Exit For
              End If
          Next
       Else
          tmp8 = tmp8 & tmp7
       End If
   Wend
   'MsgBox tmp8
   Debug.Print tmp8
   
End SubPrivate Sub iSplit(s$, wz1%, wz2%, wz3%, wz4%, tp1$, tp2$, tp3$)
    wz1 = InStr(InStr(1, s, ">") + 1, s, ">")
    wz2 = InStr(InStr(wz1 + 1, s, ">") + 1, s, ">")
    wz3 = InStr(InStr(wz2 + 1, s, ">") + 1, s, ">")
    wz4 = InStr(InStr(wz3 + 1, s, ">") + 1, s, ">")    tp1 = Trim(Mid(s, wz1 + 1, InStr(wz1 + 1, s, "<") - wz1 - 1))
    tp2 = Trim(Mid(s, wz2 + 1, InStr(wz2 + 1, s, "<") - wz2 - 1))
    tp3 = Trim(Mid(s, wz3 + 1, InStr(wz3 + 1, s, "<") - wz3 - 1))End Sub

Answer 2

我的思路是用字典，示例如下，自己优化：Dim dic As Dictionary
    Dim s As String
    Dim key As String, item As String
    
    s = "<deliver><mobile>13788888888</mobile><ext>123</ext><content>我真的</content></deliver>" & _
        "<deliver><mobile>13788888888</mobile><ext>123</ext><content>非常开心</content></deliver>" & _
        "<deliver><mobile>13788888888</mobile><ext>123</ext><content>，谢谢你</content></deliver>" & _
        "<deliver><mobile>13477777777</mobile><ext>456</ext><content>和你分手后</content></deliver>" & _
        "<deliver><mobile>13477777777</mobile><ext>456</ext><content>我很快乐</content></deliver>" & _
        "<deliver><mobile>13600000000</mobile><ext>789</ext><content>我是终结者</content></deliver>" & _
        "<deliver><mobile>13600000000</mobile><ext>000</ext><content>别合并我，我是异类</content></deliver>"
    
    Const STRING_1 = "<content>"
    Const STRING_2 = "</content></deliver>"
    
    Set dic = New Dictionary
    While InStr(s, STRING_1)
        key = Split(s, STRING_1, 2)(0) & STRING_1
        s = Replace(s, key, vbNullString, 1, 1)
        item = Mid(s, 1, InStr(s, STRING_2) - 1) & STRING_2
        s = Replace(s, item, vbNullString, 1, 1)
        If Not dic.Exists(key) Then
            dic.Add key, key & item
        Else
            dic(key) = Replace(dic(key), STRING_2, item)
        End If
    Wend
    
    '输出结果
    Dim arr
    arr = dic.Items
    Debug.Print Join(arr, vbCrLf)    '<deliver><mobile>13788888888</mobile><ext>123</ext><content>我真的非常开心，谢谢你</content></deliver>
'<deliver><mobile>13477777777</mobile><ext>456</ext><content>和你分手后我很快乐</content></deliver>
'<deliver><mobile>13600000000</mobile><ext>789</ext><content>我是终结者</content></deliver>
'<deliver><mobile>13600000000</mobile><ext>000</ext><content>别合并我，我是异类</content></deliver>

Answer 3

楼主的字符串最长的有多长？
似乎对效率没要求。
我在 s = ""<deliver><mobile>13788888888....." 之后又来了个小循环......For i = 1 To 10
       s = s & s
Next加个计时器看了一下，鲜有能跑进3秒的。

Answer 4

吃过饭发现6楼没有看清楼主问题的条件，改一下： 
'1.只有 mobile 和 ext 一致时，才 [合体]，否则孔雀东南飞
'2.条件符合 1 的话，只[合体]相邻的两条，不相邻的不[合体]Private Sub Command1_Click()
    
    Dim s As String
    Dim tmp As String
    Dim key As String, item As String
    
    s = "<deliver><mobile>13788888888</mobile><ext>123</ext><content>我真的</content></deliver>" & _
        "<deliver><mobile>13788888888</mobile><ext>123</ext><content>非常开心</content></deliver>" & _
        "<deliver><mobile>13788888888</mobile><ext>123</ext><content>，谢谢你</content></deliver>" & _
        "<deliver><mobile>13477777777</mobile><ext>456</ext><content>和你分手后</content></deliver>" & _
        "<deliver><mobile>13477777777</mobile><ext>456</ext><content>我很快乐</content></deliver>" & _
        "<deliver><mobile>13600000000</mobile><ext>789</ext><content>我是终结者</content></deliver>" & _
        "<deliver><mobile>13600000000</mobile><ext>000</ext><content>别合并我，我是异类</content></deliver>"
    s = s & s
    
    Const STRING_1 = "<content>"
    Const STRING_2 = "</content></deliver>"
    
    If InStr(s, STRING_1) = 0 Then Exit Sub
    
    Do
        key = Mid(s, 1, InStr(s, STRING_1) - 1) & STRING_1
        item = vbNullString
        Do
            s = Replace(s, key, vbNullString, 1, 1)
            tmp = Mid(s, 1, InStr(s, STRING_2) - 1)
            item = item & tmp
            s = Replace(s, tmp & STRING_2, vbNullString, 1, 1)
            If Len(s) = 0 Then Exit Do
        Loop Until Mid(s, 1, InStr(s, STRING_1) - 1) & STRING_1 <> key
        item = key & item & STRING_2
        Debug.Print item      '输出一个结果
    Loop Until InStr(s, STRING_1) = 0End Sub

Answer 5

我8楼方法如下改一改效率会比8楼的好点，数据量比较大的话，要秒杀一时想不到好方法：Private Sub Command1_Click()
    
    Dim s As String
    Dim tmp As String
    Dim key As String, item As String
    Dim x As Long, y As Long
    
    s = "<deliver><mobile>13788888888</mobile><ext>123</ext><content>我真的</content></deliver>" & _
        "<deliver><mobile>13788888888</mobile><ext>123</ext><content>非常开心</content></deliver>" & _
        "<deliver><mobile>13788888888</mobile><ext>123</ext><content>，谢谢你</content></deliver>" & _
        "<deliver><mobile>13477777777</mobile><ext>456</ext><content>和你分手后</content></deliver>" & _
        "<deliver><mobile>13477777777</mobile><ext>456</ext><content>我很快乐</content></deliver>" & _
        "<deliver><mobile>13600000000</mobile><ext>789</ext><content>我是终结者</content></deliver>" & _
        "<deliver><mobile>13600000000</mobile><ext>000</ext><content>别合并我，我是异类</content></deliver>"
    s = s & s
     
    Const STRING_1 = "<content>"
    Const STRING_2 = "</content></deliver>"
    
    x = Len(STRING_1) + 1
    y = Len(STRING_2) + 1
     
    If InStr(s, STRING_1) = 0 Then Exit Sub
    Do
        key = Mid(s, 1, InStr(s, STRING_1) - 1)
        item = vbNullString
        Do
            s = Mid(s, Len(key) + x)
            tmp = Mid(s, 1, InStr(s, STRING_2) - 1)
            item = item & tmp
            s = Mid(s, Len(tmp) + y)
            If Len(s) = 0 Then Exit Do
        Loop Until Mid(s, 1, InStr(s, STRING_1) - 1) <> key
        item = key & STRING_1 & item & STRING_2
        Debug.Print item      '输出一个结果
    Loop Until InStr(s, STRING_1) = 0
数据量大的话，item不用&串接，可以声明一个数组用join....

Answer 6

来个秒杀型的：
在窗体上放置两个文本框Text1以及Text2，都设置MultiLine属性为True。设置Text1的文本内容为:
<deliver><mobile>13788888888</mobile><ext>123</ext><content>我真的</content></deliver>
<deliver><mobile>13788888888</mobile><ext>123</ext><content>非常开心</content></deliver>
<deliver><mobile>13788888888</mobile><ext>123</ext><content>，谢谢你</content></deliver>
<deliver><mobile>13477777777</mobile><ext>456</ext><content>和你分手后</content></deliver>
<deliver><mobile>13477777777</mobile><ext>456</ext><content>我很快乐</content></deliver>
<deliver><mobile>13600000000</mobile><ext>789</ext><content>我是终结者</content></deliver>
<deliver><mobile>13600000000</mobile><ext>000</ext><content>别合并我，我是异类</content></deliver>
再放置一个按钮Command1。首先添加一个类，类名为MsgInfo，代码如下：Option ExplicitConst MobileS = "<mobile>"
Const MobileE = "</mobile>"
Const MSL = 16
Const MEL = 18Const ExtS = "<ext>"
Const ExtE = "</ext>"
Const ESL = 10
Const EEL = 12Const ContentS = "<content>"
Const ContentE = "</content>"
Const CSL = 18
Const CEL = 20Const DeliverS = "<deliver>"
Const DeliverE = "</deliver>"
Const DSL = 18
Const DEL = 20Public mlStartPos As Long '消息开始位置
Public mlMsgLen As Long '消息长度
Public mlMobile As Long 'mobile内容开始位置
Public mlMobileLen As Long 'mobile内容长度
Public mlExt As Long 'ext内容开始位置
Public mlExtLen As Long 'ext内容长度
Public mlContent As Long 'content内容开始位置
Public mlContentLen As Long 'content内容长度Private Function CanJoinTo(msgPrev As MsgInfo, bytData() As Byte) As Boolean
Dim i As Long
Dim j As Long
    '检查mobile是否相同
    If msgPrev.mlMobileLen <> mlMobileLen Then
        Exit Function
    End If
    j = msgPrev.mlMobile
    For i = mlMobile To mlMobile + mlMobileLen - 1
        If bytData(i) <> bytData(j) Then
            Exit Function
        Else
            j = j + 1
        End If
    Next i
    '检查ext是否相同
    If msgPrev.mlExtLen <> mlExtLen Then
        Exit Function
    End If
    j = msgPrev.mlExt
    For i = mlExt To mlExt + mlExtLen - 1
        If bytData(i) <> bytData(j) Then
            Exit Function
        Else
            j = j + 1
        End If
    Next i
    CanJoinTo = True
End Function
Public Function JoinTo(msgPrev As MsgInfo, bytData() As Byte) As Boolean
Dim i As Long
Dim j As Long
Dim lOffset As Long
    If CanJoinTo(msgPrev, bytData) = False Then
        j = msgPrev.mlStartPos + msgPrev.mlMsgLen
        lOffset = mlStartPos - j
        If j = mlStartPos Then
            Exit Function
        End If
        For i = mlStartPos To mlStartPos + mlMsgLen - 1
            bytData(j) = bytData(i)
            j = j + 1
        Next i
        mlStartPos = mlStartPos - lOffset
        mlMobile = mlMobile - lOffset
        mlExt = mlExt - lOffset
        mlContent = mlContent - lOffset
        Exit Function
    End If
    j = msgPrev.mlContent + msgPrev.mlContentLen
    For i = mlContent To mlStartPos + mlMsgLen - 1
        bytData(j) = bytData(i)
        j = j + 1
    Next i
    msgPrev.mlContentLen = msgPrev.mlContentLen + mlContentLen
    msgPrev.mlMsgLen = msgPrev.mlMsgLen + mlContentLen
    JoinTo = True
End FunctionPublic Function ParseMsgInfo(strVal As String, lParsePos As Long) As Boolean
Dim lDeliverPos As Long
Dim lMobilePos As Long
Dim lExtPos As Long
Dim lContentPos As Long
    mlStartPos = InStrB(lParsePos + 1, strVal, DeliverS)
    If mlStartPos <> 0 Then
        lMobilePos = mlStartPos + DSL
    Else
        Exit Function
    End If
    
    lDeliverPos = InStrB(lMobilePos, strVal, DeliverE)
    If lDeliverPos <> 0 Then
        mlMsgLen = lDeliverPos + DEL - mlStartPos
        '数组起始下标为0
        mlStartPos = mlStartPos - 1
    Else
        Exit Function
    End If
    
    '获得mobile的位置与长度
    lMobilePos = InStrB(lMobilePos, strVal, MobileS)
    If lMobilePos <> 0 Then
        mlMobile = lMobilePos + MSL
    Else
        Exit Function
    End If
    lMobilePos = InStrB(mlMobile, strVal, MobileE)
    If lMobilePos <> 0 Then
        mlMobileLen = lMobilePos - mlMobile
        '数组起始下标为0
        mlMobile = mlMobile - 1
        lExtPos = lMobilePos + MEL
    Else
        Exit Function
    End If
    
    
    '获得ext的位置与长度
    lExtPos = InStrB(lExtPos, strVal, ExtS)
    If lExtPos <> 0 Then
        mlExt = lExtPos + ESL
    Else
        Exit Function
    End If
    lExtPos = InStrB(mlExt, strVal, ExtE)
    If lExtPos <> 0 Then
        mlExtLen = lExtPos - mlExt
        '数组起始下标为0
        mlExt = mlExt - 1
        lContentPos = lExtPos + EEL
    Else
        Exit Function
    End If
    '获得content的位置与长度
    lContentPos = InStrB(lContentPos, strVal, ContentS)
    If lContentPos <> 0 Then
        mlContent = lContentPos + CSL
    Else
        Exit Function
    End If
    lContentPos = InStrB(mlContent, strVal, ContentE)
    If lContentPos <> 0 Then
        mlContentLen = lContentPos - mlContent
        '数组起始下标为0
        mlContent = mlContent - 1
    Else
        Exit Function
    End If
    '保证字符串的正确性
    If mlContent + mlContentLen + CEL + DEL <> mlStartPos + mlMsgLen Then
        Exit Function
    Else
        lParsePos = mlStartPos + mlMsgLen
    End If
    
    ParseMsgInfo = True
End Function
然后在Form1中添加如下代码'调用此函数之前请先保证字符串格式正确。
'按照<deliver><mobile></mobile><ext></ext><content></content></deliver>的顺序。
'解析时大小写敏感
'转换后的字符串保存在字节数组中
Private Function ConvertMsg(strVal As String, bytString() As Byte) As Long
Dim msgTmp As MsgInfo
Dim msgLast As New MsgInfo
Dim msgCurrent As New MsgInfo
Dim lCount As Long
Dim lParsePos As Long
    '转换字符串到字符数组
    bytString = strVal
    lParsePos = 0
    '初始化第一个消息作为上一组消息
    If msgLast.ParseMsgInfo(strVal, lParsePos) = True Then
        lCount = 1
    Else
        Exit Function
    End If
    Do While (msgCurrent.ParseMsgInfo(strVal, lParsePos) = True)
        If msgCurrent.JoinTo(msgLast, bytString) = False Then
            lCount = lCount + 1
            '互换msgCurrent与msgLast
            Set msgTmp = msgCurrent
            Set msgCurrent = msgLast
            Set msgLast = msgTmp
        End If
    Loop
    ReDim Preserve bytString(0 To msgLast.mlStartPos + msgLast.mlMsgLen - 1)
    ConvertMsg = lCount
End Function
Private Sub Command1_Click()
Dim bytData() As Byte
    ConvertMsg Text1.Text, bytData
    Text2.Text = bytData
End Sub然后运行点击Command1即可将解析后的内容显示在Text2上。绝对保证效率。

Answer 7

结帐还真快，下班路上想了下，我也来个按7楼For i = 1 To 10　s = s & s　Next以后，纯用VB函数秒杀的：    Dim s As String
    Dim tmp As String
    Dim key As String, item As String
    Dim Length_str1 As Long, Length_str2 As Long
    Dim i As Long, j As Long
    Dim idx As Long
    Dim Result() As String
    
    s = "<deliver><mobile>13788888888</mobile><ext>123</ext><content>我真的</content></deliver>" & _
        "<deliver><mobile>13788888888</mobile><ext>123</ext><content>非常开心</content></deliver>" & _
        "<deliver><mobile>13788888888</mobile><ext>123</ext><content>，谢谢你</content></deliver>" & _
        "<deliver><mobile>13477777777</mobile><ext>456</ext><content>和你分手后</content></deliver>" & _
        "<deliver><mobile>13477777777</mobile><ext>456</ext><content>我很快乐</content></deliver>" & _
        "<deliver><mobile>13600000000</mobile><ext>789</ext><content>我是终结者</content></deliver>" & _
        "<deliver><mobile>13600000000</mobile><ext>000</ext><content>别合并我，我是异类</content></deliver>"
    '7楼要求：
    For i = 1 To 10
        s = s & s
    Next
    Dim t
    t = Timer
    
    Const STRING_1 = "<content>"
    Const STRING_2 = "</content></deliver>"
      
    If InStr(s, STRING_1) = 0 Then Exit Sub
    
    Length_str1 = Len(STRING_1)
    Length_str2 = Len(STRING_2)
    
    tmp = Mid(s, 1, InStr(s, STRING_1) + Length_str1 - 1)
    ReDim Result(Len(s) \ Len(tmp))
    Do
        key = tmp
        item = vbNullString
        Do
            i = i + Len(tmp)
            j = InStr(i + 1, s, STRING_2)
            item = item & Mid(s, i, j - i)
            i = j + Length_str2
            tmp = Mid(s, i, InStr(s, STRING_1) + Length_str1 - 1)
        Loop Until tmp <> key
        Result(idx) = key & STRING_1 & item & STRING_2
        idx = idx + 1
    Loop Until Len(tmp) = 0
    'MsgBox Timer - t
    Debug.Print Trim(Join(Result, ""))  '输出结果
    MsgBox Timer - t

Answer 8

上面秒杀包含debug.print的时间，应该还可以优化，没时间，不想了....