Macro in Word to format WhatsApp conversations
Hello, I am making a macro to edit WhatsApp conversations.
When you access WhatsApp, open a conversation, tap the three dots in the upper right corner, tap" more, "and then tap" Send by email, "the conversation comes in a file."txt".
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 is more "presentable".
Text of Entry:
01/12/17, 14:29 - contact: Good Morning
01/12/17, 14:29 - Me: Good Morning, all right?
02/12/17, 15:00 - Contact: Yes
Text as I intend it to look:
December 01, 2017-2: 29pm
Contact: Good Morning
Me: Good Morning, all right?
December 02, 2017 at 3: 00 pm
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 - Me: 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 up in a loop infinite and locked Word.
1 answers
A simpler way to parse the text is to use the function Split
.
If the date and time is already in the same format as the Word language you can convert the date and use the formatting functions of the VBA itself.
I also left the separation from one date to another from Interval greater than 1 minute but you configure it according to what you find best.
Now you 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