Macro in Word to format Whatsapp conversations

Question

Hello, I’m doing a macro to edit Whatsapp conversations.

When you access Whatsapp, open a conversation, tap the three points in the upper right corner, tap "More", and then tap "Send by email", the conversation comes in a ".txt" file.

I would like to copy and paste the contents of this file into Word and use this macro to format and edit this text so that it becomes more "presentable".

Input Text:

01/12/17, 14:29 - Contact: Good morning

01/12/17, 14:29 - I: Good morning, all right?

02/12/17, 15:00 - Contact: Yes

Text as I intend it to be:

01 December 2017 at 14:29

Contact: Good morning

I: Good morning, all right?

02 December 2017 at 15:00

Contact: Yes

Text as it is getting:

//, : - Contact: Good morning

//, : - Contact: Good morning

//, : - Contact: Good morning

//, : - Contact: Good morning

//, : - Contact: Good morning

//, : - Contact: Good morning

//, : - Contact: Good morning

01/12/17, 14:29 - I: Good morning, all right?

02/12/17, 15:00 - Contact: Yes

My code:

Sub ConvertWhatsAppText()

    Dim lineText As String, lineResult As String
    Dim aux As String, actualyDate As String
    Dim mChar As String * 1
    Dim i As Integer, j As Integer, p As Integer, limitC As Integer, limitP As Integer

    Dim numbers As String
    numbers = "0123456789"

    limitP = ActiveDocument.Paragraphs.Count
    p = 1

    For Each singleLine In ActiveDocument.Paragraphs

        If p > limitP Then
            Exit For
        End If

        p = p + 1

        lineText = singleLine.Range.Text
        limitC = Len(lineText)

        For i = 1 To limitC

            If InStr(numbers, Mid(lineText, i, 1)) > 0 Then
                mChar = Mid(lineText, i, 17)

                For j = 1 To Len(mChar)
                    If InStr(numbers, Mid(mChar, j, 1)) > 0 And (j = 1 Or j = 2 Or j = 4 Or j = 5 Or j = 7 Or j = 8 Or j = 11 Or j = 12 Or j = 14 Or j = 15) Then

                    ElseIf Mid(mChar, j, 1) = "/" And (j = 3 Or j = 6) Then

                    ElseIf Mid(mChar, j, 1) = " " And (j = 10 Or j = 16) Then

                    ElseIf Mid(mChar, j, 1) = "," And (j = 9) Then

                    ElseIf Mid(mChar, j, 1) = ":" And (j = 13) Then

                    ElseIf Mid(mChar, j, i) = "-" And (j = 17) Then
                        aux = mChar

                        If Not (actualyDate = aux) Then
                            lineResult = lineResult & vbCrLf & FormatDate(aux) & vbCrLf
                            actualyDate = aux
                        Else
                            lineResult = lineResult & vbCrLf
                        End If

                    Else
                        lineResult = lineResult & Mid(lineText, i, 1)
                        Exit For
                    End If
                Next j
            Else
                lineResult = lineResult & Mid(lineText, i, 1)
            End If
        Next i
        singleLine.Range.Text = lineResult
    Next singleLine

End Sub

Function FormatDate(x As String) As String

    Dim month As String

    Select Case Mid(x, 4, 2)
        Case "01"
            month = "Janeiro"
        Case "02"
            month = "Fevereiro"
        Case "03"
            month = "Março"
        Case "04"
            month = "Abril"
        Case "05"
            month = "Maio"
        Case "06"
            month = "Junho"
        Case "07"
            month = "Julho"
        Case "08"
            month = "Agosto"
        Case "09"
            month = "Setembro"
        Case "10"
            month = "Outubro"
        Case "11"
            month = "Novembro"
        Case "12"
            month = "Dezembro"
    End Select

    FormatDate = Mid(x, 1, 2) & " de " & month & " de 20" & Mid(x, 7, 2) & " às " & Mid(x, 11, 2) & "h" & Mid(x, 14, 2) & "min"

End Function

Before declaring limitP and the p counter, when I ran the code it ended in an infinite loop and crashed Word.

Answer 1

A simpler way to parse text is to use the function Split.

If the date and time is already in the same Word language format you can convert the date and use the formatting functions of VBA itself.

I also left the separation from one date to another from interval greater than 1 minute but you configure according to what you think best.

Now we need to take more example texts and improve the function.

Sub ConvertWhatsAppText()

    Dim lineText As String
    Dim lineResult As String
    Dim numbers As String
    Dim tmp() As String

    Dim data As String
    Dim hora As String
    Dim texto As String
    Dim corrente As Date
    Dim ultima As Date
    Dim final() As String
    Dim linha As Integer
    Dim linhas As Integer
    linhas = -1

    For Each singleLine In ActiveDocument.Paragraphs

        lineText = singleLine.range.Text

        If lineText <> "" Then

            tmp = Split(lineText, ", ")

            If UBound(tmp) > 0 Then

                data = tmp(0)
                tmp = Split(tmp(1), " - ")

                If UBound(tmp) > 0 Then

                    hora = tmp(0)
                    tmp = Split(lineText, " - ")
                    texto = ""
                    For linha = 1 To UBound(tmp)
                        If linha > 1 Then
                            texto = texto + " - "
                        End If
                        texto = texto + tmp(linha)
                    Next

                    corrente = CDate(data + " " + hora)

                    If DateDiff("n", ultima, corrente) >= 1 Then
                        linhas = linhas + 1
                        ReDim Preserve final(linhas)
                        final(linhas) = Format(corrente, "Long Date") + " às " + Format(corrente, "Short Time")
                        linhas = linhas + 1
                    End If

                    ultima = corrente

                    ReDim Preserve final(linhas)
                    texto = Replace(texto, vbCrLf, "")
                    texto = Replace(texto, vbCr, "")
                    texto = Replace(texto, vbLf, "")
                    final(linhas) = texto
                    linhas = linhas + 1

                End If

            End If

        End If

    Next singleLine

    If UBound(final) >= 0 Then
        ActiveDocument.StoryRanges(wdMainTextStory).Delete

        For linha = 0 To UBound(final)
            ActiveDocument.range.InsertAfter final(linha) & vbCrLf
        Next
    End If

End Sub