Macro in Word to format WhatsApp conversations

Navigation
0

Hello, I'm doing a macro to edit WhatsApp conversations.

When you go to WhatsApp, open a conversation, touch the three dots in the upper right corner, touch "More," and then touch "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 - Me: Good morning, how are you?

     

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

Text as I want it to stay:

  

December 1, 2017 at 2:29 PM

     

Contact: Good Morning

     

Me: Good morning, how are you?

     

December 2, 2017 at 3:00 p.m.

     

Contact: Yes

Text as is:

  

//,: - 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 - Me: Good morning, how are you?

     

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 counter p, when I ran the code it would end up in an infinite loop and lock Word.

    
asked by anonymous 13.07.2018 / 06:44

1 answer

1

A simpler way to parse text is to use Split .

If the date and time are already in the same format as the Word language, 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 you need to get more sample 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
    
13.07.2018 / 14:51
Rendering map using API with spring boot Where with date and time - Entity Framework