Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
#Compiler PBWin 10
#Compile Exe
#Dim All
%Unicode = 1
#Include "Win32API.inc"
Enum Equates Singular
IDC_Button
End Enum
Global hDlg As Dword
Function PBMain() As Long
Dialog New Pixels, 0, "PowerBASIC",300,300,200,200, %WS_OverlappedWindow To hDlg
Control Add Button, hDlg, %IDC_Button,"Push", 50,10,100,20
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Select Case Cb.Msg
Case %WM_Command
Select Case Cb.Ctl
Case %IDC_Button
? Get_Qp2Text("From: =?UTF-8?Q?Yahoo?= <[email protected]>")
? Get_Qp2Text("Subject: =?UTF-8?Q?Hi=2Cstay=20connected=20with=20Yahoo=20Mail=20mobile=20app?=")
End Select
End Select
End Function
Function Get_Qp2Text(ByVal EncodedText As String) As String
Dim i As Local Long '
Dim p0 As Local Long '
Dim p1 As Local Long '
Dim p2 As Local Long '
Dim pChar As Local Long '
Dim strText As Local String '
Dim szDest As Local AsciiZ * '
Dim strRun As Local String '
Dim strTmp As Local String '
Dim Charset As Local String '
Dim Charset_IDs As Local String '
Dim Base64 As Local Long '
Dim QuotedPrint As Local Long '
Dim UTF8 As Local Long
Dim Id As Local String '
Charset_IDs$ = "=?ISO-8859-1? =?ISO-8859-15? =?WINDOWS-1252? =?UTF-8? =?UTF-7?"
' originale Zeile erstmal umkopieren
strText = EncodedText
For i& = 1 To ParseCount(Charset_IDs, " ")
Charset = Parse$(Charset_IDs, " " , i&)
If InStr(UCase$(EncodedText), Charset) > 0 Then
' mehrere einzeln kodierte Zeichen dekodieren
p0 = InStr(UCase$(EncodedText), Charset)
If p0 > 0 Then
Do
Id = ""
Base64 = %False
QuotedPrint = %False
If p0 > 0 Then
' originale Zeile l�schen
strText = ""
' fnhrende unkodierte Zeichen sichern
strRun = Left$(EncodedText, p0 - 1)
p0 = p0 + Len(Charset)
If InStr(p0, UCase$(EncodedText), "Q?") > 0 Then Base64 = %False: Id = "Q?"
If InStr(p0, UCase$(EncodedText), "B?") > 0 Then Base64 = %True : Id = "B?"
If Id <> "" Then
p1 = InStr(p0 - 1, UCase$(EncodedText), Id) + 2
p2 = InStr(p1, EncodedText, "?=") - 1
p0 = InStr(p2, UCase$(EncodedText), Charset)
If p2 < 0 Then p2 = Len(EncodedText) ' Encoded-String ist defekt, auf echtes Ende setzen
If Base64 = %True Then
? "not supported"
Else
For pChar = p1 To p2
Select Case Mid$(EncodedText, pChar, 1)
Case "="
strText = strText & Chr$(Val("&H" & Mid$(EncodedText, pChar + 1, 2)))
pChar = pChar + 2
Case "_"
strText = strText & Chr$(32)
Case Else
strText = strText & Mid$(EncodedText, pChar, 1)
End Select
Next pChar
End If
' Leerzeichen zwischen encoded Words enfernen
p0 = InStr(UCase$(Mid$(EncodedText, p2 + 3)), Charset)
If p0 > 0 Then
strText = strText & Mid$(EncodedText, p0 + p2 + 2)
Else
strText = strText & Mid$(EncodedText, p2 + 3)
End If
Else
End If
strText = strRun + strText
Else
End If
EncodedText = strText
' nochmal justieren
p0 = InStr(UCase$(EncodedText), Charset)
Loop Until p0 = 0
Exit For
Else
End If
Else
Charset$ = ""
End If
Next i&
Select Case UCase$(Charset$)
Case "=?UTF-8?"
strRun = Utf8ToChr$(EncodedText)
Case "=?UTF-7?"
Case Else
' Zeichensatz auf Console umstricken (blockweise da Zeile sich eventuell nicht
' an RFC-Standard hSlt)
' Hinweis: Es werden auch nicht-kodierte Zeilen per Default umgewandelt, da diverse
' Mail/Newsreader hierbei die Kodierung vergessen
strRun = ""
For p1 = 1 To Len(strText) Step 200
strTmp = Mid$(strText, p1, 200)
CharToOem strTmp + Chr$(0), szDest
strRun = strRun + szDest
Next p1
End Select
Function = strRun
End Function
http://www.garybeene.com/sw/gbsnippets.htm