home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / clickb1r / printmai.bas < prev    next >
Encoding:
BASIC Source File  |  1999-07-21  |  14.7 KB  |  334 lines
  1. Attribute VB_Name = "Module1"
  2.     Dim strdata As String           'variable for included/excluded words
  3.     Dim base64 As String
  4.     Dim counter As Integer          'counts through included/excluded words
  5.     Dim filenam As String           'filename of file to extract
  6.     Dim firstline As String         'each line of .eml file
  7.     Dim appath As String            'application & .eml file path
  8.  
  9.  Private Function Base64Decode(Basein As String) As String
  10.  
  11.     Dim counter As Integer
  12.     Dim Temp As String
  13.     'For the dec. Tab
  14.     Dim DecodeTable As Variant
  15.     Dim Out(2) As Byte
  16.     Dim inp(3) As Byte
  17.     
  18.     'DecodeTable holds the decode tab
  19.     DecodeTable = Array("255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "62", "255", "255", "255", "63", "52", "53", "54", "55", "56", "57", "58", "59", "60", "61", "255", "255", "255", "64", "255", "255", "255", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", _
  20.     "18", "19", "20", "21", "22", "23", "24", "25", "255", "255", "255", "255", "255", "255", "26", "27", "28", "29", "30", "31", "32", "33", "34", "35", "36", "37", "38", "39", "40", "41", "42", "43", "44", "45", "46", "47", "48", "49", "50", "51", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255" _
  21.     , "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255", "255")
  22.     'Reads 4 Bytes in and decrypt them
  23.  
  24.     For counter = 1 To Len(Basein) Step 4
  25.         '4 Bytes in -> 3 Bytes out
  26.         inp(0) = DecodeTable(Asc(Mid$(Basein, counter, 1)))
  27.         inp(1) = DecodeTable(Asc(Mid$(Basein, counter + 1, 1)))
  28.         inp(2) = DecodeTable(Asc(Mid$(Basein, counter + 2, 1)))
  29.         inp(3) = DecodeTable(Asc(Mid$(Basein, counter + 3, 1)))
  30.         Out(0) = (inp(0) * 4) Or ((inp(1) \ 16) And &H3)
  31.         Out(1) = ((inp(1) And &HF) * 16) Or ((inp(2) \ 4) And &HF)
  32.         Out(2) = ((inp(2) And &H3) * 64) Or inp(3)
  33.         '* look for "=" symbols
  34.  
  35.         If inp(2) = 64 Then
  36.             'If there are 2 characters left -> 1 binary out
  37.             Out(0) = (inp(0) * 4) Or ((inp(1) \ 16) And &H3)
  38.             Temp = Temp & Chr(Out(0) And &HFF)
  39.         ElseIf inp(3) = 64 Then
  40.             'If there are 3 characters left -> 2 binaries out
  41.             Out(0) = (inp(0) * 4) Or ((inp(1) \ 16) And &H3)
  42.             Out(1) = ((inp(1) And &HF) * 16) Or ((inp(2) \ 4) And &HF)
  43.             Temp = Temp & Chr(Out(0) And &HFF) & Chr(Out(1) And &HFF)
  44.         Else 'Return three Bytes
  45.             Temp = Temp & Chr(Out(0) And &HFF) & Chr(Out(1) And &HFF) & Chr(Out(2) And &HFF)
  46.         End If
  47.  
  48.     Next
  49.  
  50.     Base64Decode = Temp
  51.     
  52. End Function
  53.  
  54.  
  55. Private Sub decode()
  56.  
  57.     'filenam = Mid(firstline, 8, Len(firstline) - 8)     'get filename of file to extract
  58.     'Line Input #2, firstline
  59.     
  60.     If filenam = "" Then
  61.         decodeimbed64
  62.     ElseIf base64 = "base64" Then
  63.         decode64
  64.     ElseIf Right(filenam, 4) = ".rtf" Then
  65.         decodeRTF
  66.     ElseIf Right(filenam, 4) = ".txt" Then
  67.         decodeTXT
  68.     Else
  69.         Print #1,
  70.         Print #1, Chr(9) + "file: " + filenam + " NOT extracted"
  71.         Do While Not EOF(2)
  72.         Line Input #2, firstline
  73.             Do Until strdata = "EndofData"      'repeat until all invalid words checked
  74.                 getbadwords                                 ' get next invalid word
  75.                 If InStr(firstline, strdata) Then Exit Do       'if line includes invalid word then exit loop
  76.             Loop                        ' round again for next invalid word
  77.             If strdata <> "EndofData" Then Exit Do
  78.         Loop
  79.         strdata = "NextPart"
  80.         Exit Sub
  81.     End If
  82.     
  83.     Close #3
  84.     Print #1,
  85.     Print #1, Chr(9) + "file: " + filenam + " extracted"
  86.     strdata = "NextPart"
  87.     filenam = ""
  88.     base64 = ""
  89.     
  90. End Sub
  91.     
  92. Private Sub decode64()
  93.     
  94.     Dim bin64 As String
  95.     
  96.     Open appath + "\" + filenam For Output As #3    'open file to extract to
  97.     
  98.     While Trim(firstline) <> ""             'get rid of blank lines
  99.         Line Input #2, firstline
  100.     Wend
  101.     
  102.     While InStr(firstline, "NextPart") = Not True       'till end of data
  103.         Line Input #2, firstline
  104.         If (Len(firstline) Mod 4) = 0 Then     'line must be a multiple of 4
  105.             bin64 = Base64Decode(firstline)    'call decoder
  106.             Print #3, bin64;                'print decoded data to file
  107.         Else
  108.             Exit Sub
  109.         End If
  110.     Wend
  111.     
  112. End Sub
  113.  
  114. Private Sub decodeimbed64()
  115.     
  116.     Dim bin64 As String
  117.     
  118.     While Trim(firstline) <> ""             'get rid of blank lines
  119.         Line Input #2, firstline
  120.     Wend
  121.     
  122.     While InStr(firstline, "NextPart") = Not True       'till end of data
  123.         Line Input #2, firstline
  124.         If (Len(firstline) Mod 4) = 0 Then     'line must be a multiple of 4
  125.             bin64 = Base64Decode(firstline)    'call decoder
  126.             Print #1, bin64;                'print decoded data to file
  127.         Else
  128.             Exit Sub
  129.         End If
  130.     Wend
  131.     
  132. End Sub
  133.  
  134. Private Sub decodeRTF()
  135.  
  136.     Open appath + "\" + filenam For Output As #3    'open file to extract to
  137.     
  138.     While Trim(firstline) <> ""             'get rid of blank lines
  139.         Line Input #2, firstline
  140.     Wend
  141.     
  142.     While InStr(firstline, "NextPart") = Not True       'till end of data
  143.         Line Input #2, firstline
  144.         If Right(firstline, 1) = "=" Then
  145.             Print #3, Left(firstline, Len(firstline) - 1);
  146.         ElseIf Len(firstline) < 3 Then
  147.             Print #3, firstline
  148.         ElseIf Len(firstline) > 2 And Mid(firstline, Len(firstline) - 2, 1) = "=" Then
  149.             Print #3, Left(firstline, Len(firstline) - 3);
  150.         ElseIf InStr(firstline, "NextPart") = Not True Then
  151.             Print #3, firstline
  152.         End If
  153.     Wend
  154.     
  155. End Sub
  156.  
  157. Private Sub decodeTXT()
  158.  
  159.     Open appath + "\" + filenam For Output As #3    'open file to extract to
  160.     
  161.     While Trim(firstline) <> ""             'get rid of blank lines
  162.         Line Input #2, firstline
  163.     Wend
  164.     
  165.     While InStr(firstline, "NextPart") = Not True       'till end of data
  166.         Line Input #2, firstline
  167.         If InStr(firstline, "NextPart") = Not True Then
  168.             If Right(firstline, 1) = "=" Then
  169.                 Print #3, Left(firstline, Len(firstline) - 1)
  170.             Else
  171.                 Print #3, firstline
  172.             End If
  173.         End If
  174.     Wend
  175.     
  176. End Sub
  177.  Private Sub Main()
  178.  
  179.     Dim nextfile As String      'filename of .eml file
  180.     Dim lastline As String      'checks multiple blank lines
  181.     Dim filenum As Integer      'counts messages
  182.     
  183.     appath = App.Path           'sets path
  184.     nextfile = Dir(appath + "\*.eml")       'gets first .eml filename
  185.     strdata = ""                            'initialises variable
  186.     
  187.     'HEADER SECTION
  188.     
  189.     If nextfile <> "" Then
  190.         Open appath + "\EHCNet3.tmp" For Output As #1    'if .eml file present open text file for writing
  191.         Open appath + "\EHCNet3.txt" For Output As #4    'if .eml file present open index file for writing
  192.         form1.Visible = True
  193.         form1.Refresh
  194.     End If
  195.     
  196.     Print #1,
  197.     Print #1, "---------- End of INDEX------------------------------------" 'print mesage divider
  198.     Print #4,
  199.     Print #4, Chr(9) + Chr(9) + "INDEX"
  200.     Print #4,
  201.         
  202.     While nextfile <> ""                'repeat until all .eml files deleted
  203.         filenum = filenum + 1           'start counting messages
  204.         filenam = ""
  205.         base64 = ""
  206.         Print #1,
  207.         Print #1, "Message:" + Str(filenum)
  208.         Print #1,
  209.         Open appath + "\" + nextfile For Input As #2    'open .eml file for reading
  210.         firstline = "firstline"         'initialise variable with dummy value
  211.         Do Until Trim(firstline) = ""         'repeat until end of header section (first blank line)
  212.             Line Input #2, firstline        'get each line
  213.             Do Until strdata = "EndofData"      'repeat until all valid words checked
  214.                 getgoodwords                        'get next valid word
  215.                 If InStr(firstline, strdata) Then   'if line includes word then line may be valid
  216.                     If InStr(firstline, "-To:") Or InStr(firstline, "-Date:") Then     'two more to check
  217.                         Exit Do     'and exit loop
  218.                     Else
  219.                         Print #1, firstline     'all ok - print to text file
  220.                         If InStr(firstline, "Subject:") Then Print #4, Str(filenum) + "." + Chr(9) + Right(firstline, Len(firstline) - 9)
  221.                         Exit Do
  222.                     End If
  223.                 End If
  224.             Loop                        'round again for next valid word
  225.             strdata = ""        'reset variable
  226.             counter = 0         'reset counter
  227.         Loop                'round again for next line
  228.             
  229.         Print #1,          'print blank line then on to...
  230.         
  231.         'MESSAGE SECTION
  232.         
  233.         lastline = ""
  234.         Do While Not EOF(2)             'repeat until end of file
  235.             Line Input #2, firstline        'get next line
  236.             strdata = ""                                    'reset variable
  237.             Do Until strdata = "EndofData"      'repeat until all invalid words checked
  238.                 getbadwords                                 ' get next invalid word
  239.                 If InStr(firstline, strdata) Then Exit Do       'if line includes invalid word then exit loop
  240.             Loop                        ' round again for next invalid word
  241.             counter = 0                 'reset counter
  242.             
  243.             If InStr(firstline, "name=") Then
  244.                 filenam = Mid(firstline, InStr(firstline, Chr(34)) + 1, Len(firstline) - InStr(firstline, Chr(34)) - 1)
  245.                 While Trim(firstline) <> ""
  246.                     Line Input #2, firstline
  247.                     If InStr(firstline, "base64") Then base64 = "base64"
  248.                 Wend
  249.                 decode
  250.             End If
  251.             
  252.             If InStr(firstline, "base64") Then
  253.                 base64 = "base64"
  254.                 While Trim(firstline) <> ""
  255.                     Line Input #2, firstline
  256.                     If InStr(firstline, "name=") Then filenam = Mid(firstline, InStr(firstline, Chr(34)) + 1, Len(firstline) - InStr(firstline, Chr(34)) - 1)
  257.                 Wend
  258.                 decode
  259.             End If
  260.             
  261.             If strdata = "<HTML>" Then      'if next part of message in unsuitable format then...
  262.                     Print #1,               'print blank line
  263.                     Print #1, Chr(9) + "(HTML following not printed)"          'print message
  264.                     Do While Not EOF(2)
  265.                         If InStr(firstline, "NextPart") = Not True Then
  266.                             Line Input #2, firstline
  267.                         Else
  268.                             Exit Do
  269.                         End If
  270.                     Loop
  271.                     strdata = "NextPart"
  272.             End If
  273.             
  274.             If Trim(firstline) = "" And Trim(lastline) = "" Then strdata = "dummy"    'checks for second blank line
  275.                 
  276.             If strdata = "EndofData" Then               'line valid
  277.                 If Right(firstline, 1) = "=" Then firstline = Left(firstline, Len(firstline) - 1)       'get rid of = at end of some lines
  278.                 If Right(firstline, 3) = "=20" Then firstline = Left(firstline, Len(firstline) - 3)      'get rid of =20 at end of some lines
  279.                 Print #1, Trim(firstline)       'valid word - print line
  280.                 lastline = firstline
  281.             End If
  282.         
  283.         Loop
  284.         
  285.         Print #1,                                           'print blank line
  286.         Print #1, "---------- End of Message" + Str(filenum) + " ------------------------------" 'print mesage divider
  287.         
  288.         Close #2                                            'close .eml file
  289.         
  290.         Kill appath + "\" + nextfile                        'delete .eml file
  291.         nextfile = Dir(appath + "\*.eml")                   'get name of next .eml file
  292.         
  293.     Wend                                                    'repeat for next file
  294.     
  295.     Close #1                                                'close temp file
  296.     
  297.     Open appath + "\EHCNet3.tmp" For Input As #1
  298.     While Not EOF(1)
  299.         Line Input #1, firstline
  300.         Print #4, firstline
  301.     Wend
  302.     
  303.     Close #1, #4
  304.     Kill appath + "\EHCNet3.tmp"
  305.     
  306.     End                                                     'end program
  307.  
  308. End Sub
  309.  
  310. Private Sub getgoodwords()      'routine to fetch 'valid' words in header section
  311.     
  312.     Dim alldata As String       'variable to hold all words
  313.     Dim nextcomma As Integer    'variable to hold position of next comma in string
  314.     
  315.     counter = counter + 1       'sets start of search to one past last comma
  316.     alldata = "To:,Cc:,Bcc:,From:,Date:,Subject:,EndofData,"        'valid words
  317.     nextcomma = InStr(counter + 1, alldata, ",")            'find position of next comma
  318.     strdata = Mid(alldata, counter, nextcomma - counter)    'use this to find next word
  319.     counter = nextcomma                 'set position to search from next time
  320.     
  321. End Sub
  322. Private Sub getbadwords()       'routine to fetch 'invalid' words
  323.     
  324.     Dim alldata As String       'as above for 'invalid' words in message section
  325.     Dim nextcomma As Integer
  326.     
  327.     counter = counter + 1
  328.     alldata = "multipart,DOCTYPE,Message-ID:,MIME-Version:,Content-,Status:,charset=,X-Priority,X-MSMail,X-Mailer,X-MimeOLE,NextPart,X-SMF,Multipart,Multi-Part,boundary,--------,multi-part,--- Return,--- Message,<HTML>,EndofData,"
  329.     nextcomma = InStr(counter + 1, alldata, ",")
  330.     strdata = Mid(alldata, counter, nextcomma - counter)
  331.     counter = nextcomma
  332.     
  333. End Sub
  334.