home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD30291242000.psc / MIMEEncode.cls < prev   
Encoding:
Visual Basic class definition  |  2000-01-25  |  15.8 KB  |  488 lines

  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "CMHTML"
  10. Attribute VB_GlobalNameSpace = True
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. '
  15. ' Author: Gary Ong
  16. ' Acknowledgements: Sebastian, Luis Cantero for EncodeBase64
  17. '                   Brian Anderson for the SMTP Winsock code
  18. '
  19.  
  20. Option Explicit
  21. Option Compare Text
  22.  
  23. Public Event StatusUpdate(vsText As String, vlEventType As StatusEventType)
  24.  
  25. Public Enum StatusEventType
  26.     glSETInfo = 0
  27.     glSETWarning = 1
  28.     glSETError = 2
  29. End Enum
  30.  
  31. Private Const BOUNDARY_ID As String = "NextMimePart"
  32.  
  33. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  34.  
  35. Private Response            As String       ' Used to store server response code
  36. Private frmWS               As frmWinsock
  37. Private WithEvents Winsock1 As Winsock
  38. Attribute Winsock1.VB_VarHelpID = -1
  39. Private mdicAttachments     As Dictionary   ' store attachment filename and CID
  40. Private mnTimeout           As Integer      ' timeout period in seconds
  41. Private mbOmitHeader        As Boolean      ' debug property if true will omit all mail headers
  42. Private mbSaveSession       As Boolean      ' debug property if true will write session details to app.path \ session.txt
  43. Private miSessionFile       As Integer      ' file handler for saving session text
  44.  
  45. Private Sub Class_Initialize()
  46.  
  47.     Set frmWS = New frmWinsock
  48.     Set Winsock1 = frmWS.Winsock1
  49.     Set mdicAttachments = New Dictionary
  50.     mnTimeout = 25 'default timeout (sec)
  51.     
  52. End Sub
  53.  
  54. Private Sub Class_Terminate()
  55.     
  56.     Set Winsock1 = Nothing
  57.     Unload frmWS
  58.     Set frmWS = Nothing
  59.     Set mdicAttachments = Nothing
  60.  
  61. End Sub
  62.  
  63. Public Property Let ResponseTimeout(ByVal vnTimeoutInSeconds As Integer)
  64.     mnTimeout = vnTimeoutInSeconds
  65. End Property
  66.  
  67. Public Property Get ResponseTimeout() As Integer
  68.     ResponseTimeout = mnTimeout
  69. End Property
  70.  
  71. Public Property Let OmitHeader(ByVal vbMode As Boolean)
  72.     mbOmitHeader = vbMode
  73. End Property
  74.  
  75. Public Property Let SaveSession(ByVal vbMode As Boolean)
  76.     mbSaveSession = vbMode
  77. End Property
  78.  
  79. Public Function AddAttachment(ByVal vsFilename As String, Optional ByVal vsContentID As String) As Boolean
  80.     On Error GoTo ErrAddAttachment
  81.     
  82.     AddAttachment = False
  83.     
  84.     If Dir$(vsFilename) <> vbNullString Then
  85.         
  86.         ' Add attachments to dictionary for encoding later
  87.         If vsContentID = vbNullString Then
  88.             mdicAttachments.Add vsFilename, vsFilename 'use the full pathname as the key
  89.         Else
  90.             mdicAttachments.Add vsContentID, vsFilename 'use the provided ContentID
  91.         End If
  92.         AddAttachment = True
  93.     
  94.     End If
  95.     Exit Function
  96.     
  97. ErrAddAttachment:
  98.  
  99. End Function
  100.  
  101. Public Function SendEmail(ByVal vsMailServerName As String, ByVal vsFromName As String, _
  102.         ByVal vsFromEmailAddress As String, ByVal vsToEmailAddress As String, _
  103.         ByVal vsEmailSubject As String, ByVal vsEmailBodyOfMessage As String) As Boolean
  104.     
  105.     Dim sDateNow    As String
  106.     Dim sFrom       As String
  107.     Dim sTo         As String
  108.     Dim sDate       As String
  109.     Dim sFromDetail As String
  110.     Dim sToDetail   As String
  111.     Dim sSubject    As String
  112.     Dim sBody       As String
  113.     Dim sBodyHeader As String
  114.     Dim sMailerName As String
  115.     Dim sMIMEHeader As String
  116.     Dim sDomain     As String
  117.     Dim iPos        As Integer
  118.     Dim iRecipCount As Integer
  119.     Dim vRecipients As Variant
  120.     Dim i           As Integer
  121.     
  122.     SendEmail = False
  123.     
  124.     ' Sanity check parameters
  125.     If vsMailServerName = vbNullString Or vsFromName = vbNullString Or _
  126.         vsFromEmailAddress = vbNullString Or vsToEmailAddress = vbNullString Then
  127.         RaiseEvent StatusUpdate("Missing parameter in call to SendEmail", glSETError)
  128.         Exit Function
  129.     End If
  130.     
  131.     ' Open the debug output file if specified
  132.     If mbSaveSession Then
  133.         miSessionFile = FreeFile
  134.         Open App.Path & "\session.txt" For Output As #miSessionFile
  135.     End If
  136.     
  137.     ' Convert comma/semicolon delimited string into an array
  138.     iRecipCount = GetRecipients(vsToEmailAddress, vRecipients)
  139.     
  140.     Winsock1.LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail pre program start
  141.     
  142.     If Winsock1.State = sckClosed Then ' Check to see if socet is closed
  143.         
  144.         If Not mbOmitHeader Then
  145.         
  146.             sDateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss")
  147.             sFrom = "mail from:" & " <" + vsFromEmailAddress + ">" & vbCrLf  ' Get who's sending E-Mail address
  148.             
  149.             sToDetail = "To: undisclosed recipients" & vbCrLf   ' Hide who its going to
  150.             sDate = "Date:" + Chr(32) + sDateNow + vbCrLf ' Date when being sent
  151.             sFromDetail = "From: " & Chr(34) & vsFromName & Chr(34) & " <" + vsFromEmailAddress + ">" + vbCrLf  ' Who's Sending
  152.             sSubject = "Subject:" + Chr(32) + vsEmailSubject + vbCrLf ' Subject of E-Mail
  153.             sBody = vsEmailBodyOfMessage + vbCrLf ' E-mail message body
  154.             sMailerName = "X-Mailer: GOMail" + vbCrLf ' What program sent the e-mail, customize this
  155.             
  156.             sMIMEHeader = GetMIMEHeader(BOUNDARY_ID)
  157.             
  158.             sBodyHeader = sFromDetail + sDate + sMailerName + sToDetail + sSubject & sMIMEHeader  ' Combine for proper SMTP sending
  159.         
  160.         Else
  161.         
  162.             ' This is good for debugging as you can eliminate possible problems
  163.             ' in the email header. The email message content will be only the
  164.             ' vsBodyOfMessage parameter.
  165.             
  166.             sFrom = "mail from:" & " <" + vsFromEmailAddress + ">" & vbCrLf  ' Get who's sending E-Mail address
  167.             sBody = vsEmailBodyOfMessage + vbCrLf
  168.         
  169.         End If
  170.         
  171.         ' Derive domain name from senders email address
  172.         sDomain = vsFromEmailAddress
  173.         iPos = Len(sDomain) - InStr(sDomain, "@")
  174.         sDomain = Right$(sDomain, iPos)
  175.         
  176.         Winsock1.Protocol = sckTCPProtocol ' Set protocol for sending
  177.         Winsock1.RemoteHost = vsMailServerName ' Set the server address
  178.         Winsock1.RemotePort = 25 ' Set the SMTP Port
  179.         Winsock1.Connect ' Start connection
  180.         
  181.         WaitFor ("220")
  182.         RaiseEvent StatusUpdate("Connecting...", glSETInfo)
  183.         
  184.         Call SendData("HELO " & sDomain & vbCrLf)
  185.         WaitFor ("250")
  186.         RaiseEvent StatusUpdate("Connected", glSETInfo)
  187.     
  188.         Call SendData(sFrom)
  189.         RaiseEvent StatusUpdate("Sending message...", glSETInfo)
  190.         WaitFor ("250")
  191.     
  192.         ' List the email recipients
  193.         For i = 0 To iRecipCount - 1
  194.             If Trim$(vRecipients(i)) <> "" Then
  195.                 Call SendData("RCPT TO: " & "<" & Trim$(vRecipients(i)) & ">" & vbCrLf)
  196.                 WaitFor ("250")
  197.             End If
  198.         Next
  199.     
  200.         ' This the email body
  201.         Call SendData("data" + vbCrLf)
  202.         WaitFor ("354")
  203.         
  204.         If Not mbOmitHeader Then
  205.         
  206.             Call SendData(sBodyHeader + vbCrLf)
  207.             Call SendData(sBody)
  208.             Call SendData(EncodeAttachments())
  209.             
  210.         Else
  211.         
  212.             Call SendData(sBody)
  213.             
  214.         End If
  215.         
  216.         ' This is how we end the SMTP session
  217.         Call SendData(vbCrLf & "." & vbCrLf)
  218.         WaitFor ("250")
  219.     
  220.         Call SendData("quit" + vbCrLf)
  221.         RaiseEvent StatusUpdate("Disconnecting...", glSETInfo)
  222.         WaitFor ("221")
  223.     
  224.         Winsock1.Close
  225.         
  226.         RaiseEvent StatusUpdate("Mail sent", glSETInfo)
  227.         SendEmail = True
  228.         
  229.     Else
  230.         RaiseEvent StatusUpdate("Internal error - winsock control in unexpected state", glSETError)
  231.     End If
  232.        
  233.     ' Remove all attachments after send
  234.     mdicAttachments.RemoveAll
  235.     
  236.     ' Close the debug output file
  237.     If mbSaveSession Then
  238.         Close #miSessionFile
  239.     End If
  240.     
  241. End Function
  242.  
  243. Private Sub SendData(ByVal vsData As String)
  244.  
  245.     Winsock1.SendData vsData
  246.     Debug.Print vsData
  247.     If mbSaveSession Then
  248.         Print #miSessionFile, vsData
  249.     End If
  250.     
  251. End Sub
  252.  
  253. Private Function GetRecipients(ByVal vsList As String, ByRef vvList As Variant) As Integer
  254.  
  255.     ' Check for multiple recipients delimited by commas or semi-colons
  256.     If InStr(vsList, ",") <> 0 Then
  257.         vvList = Split(vsList, ",")
  258.         GetRecipients = UBound(vvList) + 1
  259.     Else
  260.         If InStr(vsList, ";") <> 0 Then
  261.             vvList = Split(vsList, ";")
  262.             GetRecipients = UBound(vvList) + 1
  263.         Else
  264.             ' Only one recipient
  265.             GetRecipients = 1
  266.             vvList = Array(vsList)
  267.         End If
  268.     End If
  269.  
  270. End Function
  271.  
  272. Private Sub WaitFor(ResponseCode As String)
  273.     Dim Start               As Single
  274.     Dim Tmr                 As Single
  275.     
  276.     Start = Timer ' Time event so won't get stuck in loop
  277.     While Len(Response) = 0
  278.         Tmr = Start - Timer
  279.         DoEvents ' Let System keep checking for incoming response **IMPORTANT**
  280.         If Tmr > mnTimeout Then ' Time in seconds to wait
  281.             RaiseEvent StatusUpdate("SMTP service error, timed out while waiting for response", glSETError)
  282.             Exit Sub
  283.         End If
  284.         Sleep 1  ' to prevent hogging of the CPU
  285.     Wend
  286.     
  287.     While Left(Response, 3) <> ResponseCode
  288.         DoEvents
  289.         If Tmr > 50 Then
  290.             RaiseEvent StatusUpdate("SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, glSETError)
  291.             Exit Sub
  292.         End If
  293.         Sleep 1  ' to prevent hogging of the CPU
  294.     Wend
  295.     Response = "" ' Sent response code to blank **IMPORTANT**
  296.     
  297. End Sub
  298.  
  299. Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
  300.  
  301.     Winsock1.GetData Response ' Check for incoming response *IMPORTANT*
  302.  
  303. End Sub
  304.  
  305. Public Function GetMIMEHeader(ByVal vsBoundaryID As String) As String
  306.     
  307.     GetMIMEHeader = "MIME-Version: 1.0" & vbCrLf & _
  308.         "Content-Type: multipart/related; boundary=" & _
  309.         Chr(34) & vsBoundaryID & Chr(34) & "; type=" & Chr(34) & _
  310.         "text/html" & Chr(34) & vbCrLf & _
  311.         "Text displayed only to non-MIME-compliant mailers" & vbCrLf & _
  312.         "--" & vsBoundaryID & vbCrLf & _
  313.         "Content-Type: text/html; charset=us-ascii" & vbCrLf & _
  314.         "Content-Transfer-Encoding: 7bit" & vbCrLf
  315.         
  316. End Function
  317.  
  318. Private Function EncodeAttachments() As String
  319.     Dim sResult As String
  320.     Dim n As Integer
  321.     Dim k As Variant
  322.     Dim i As Variant
  323.     
  324.     k = mdicAttachments.Keys
  325.     i = mdicAttachments.Items
  326.     
  327.     If mdicAttachments.Count > 0 Then
  328.         For n = 1 To mdicAttachments.Count
  329.             sResult = sResult & EncodeFile(i(n - 1), k(n - 1), BOUNDARY_ID)
  330.         Next
  331.     End If
  332.     
  333.     sResult = sResult & vbCrLf & "--" & BOUNDARY_ID & "--" & vbCrLf
  334.     EncodeAttachments = sResult
  335.  
  336. End Function
  337.  
  338. Public Function EncodeFile(ByVal vsFullPathname As String, ByVal vsCID As String, ByVal vsBoundaryID As String) As String
  339.     Dim sResult As String
  340.     Dim sFileName As String
  341.     
  342.     sFileName = GetFilename(vsFullPathname)
  343.     
  344.     'Preparing the Mime Header
  345.     sResult = vbCrLf & "--" & vsBoundaryID & vbNewLine
  346.     sResult = sResult & "Content-Type: application/octet-stream; name=" & Chr(34) & sFileName & Chr(34) & vbNewLine
  347.     sResult = sResult & "Content-ID: <" & vsCID & ">" & vbNewLine
  348.     sResult = sResult & "Content-Transfer-Encoding: base64" & vbNewLine
  349.     sResult = sResult & "Content-Disposition: attachment; filename=" & Chr(34) & sFileName & Chr(34) & vbNewLine
  350.     
  351.     sResult = sResult & EncodeBase64(vsFullPathname)
  352.  
  353.     EncodeFile = sResult
  354.     
  355. End Function
  356.  
  357. Private Function GetFilename(ByVal vsFullPathname As String, Optional ByVal vbOmitExtension As Boolean = False) As String
  358.     Dim iBackslashPos As Integer
  359.     Dim iExtensionPos As Integer
  360.     Dim i As Integer
  361.     
  362.     For i = Len(vsFullPathname) To 1 Step -1
  363.         iBackslashPos = InStr(i, vsFullPathname, "\")
  364.         If iBackslashPos > 0 Then Exit For
  365.     Next
  366.     
  367.     If Not vbOmitExtension Then
  368.         GetFilename = Mid(vsFullPathname, iBackslashPos + 1)
  369.     Else
  370.     
  371.         For i = Len(vsFullPathname) To 1 Step -1
  372.             iExtensionPos = InStr(i, vsFullPathname, ".")
  373.             If iExtensionPos > 0 Then Exit For
  374.         Next
  375.         
  376.         GetFilename = Mid(vsFullPathname, iBackslashPos + 1, iExtensionPos - iBackslashPos - 1)
  377.     
  378.     End If
  379.     
  380. End Function
  381.  
  382. Public Function EncodeBase64(ByVal vsFullPathname As String) As String
  383.     'For Encoding BASE64
  384.     Dim b           As Integer
  385.     Dim Base64Tab   As Variant
  386.     Dim bin(3)      As Byte
  387.     Dim s           As String
  388.     Dim l           As Long
  389.     Dim i           As Long
  390.     Dim FileIn      As Long
  391.     Dim sResult     As String
  392.     Dim n           As Long
  393.     
  394.     'Base64Tab=>tabla de tabulaci≤n
  395.     Base64Tab = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "+", "/")
  396.     
  397.     Erase bin
  398.     l = 0: i = 0: FileIn = 0: b = 0:
  399.     s = ""
  400.     
  401.     'Gets the next free filenumber
  402.     FileIn = FreeFile
  403.     
  404.     'Open Base64 Input File
  405.     Open vsFullPathname For Binary As FileIn
  406.     
  407.     sResult = s & vbCrLf
  408.     s = ""
  409.     
  410.     l = LOF(FileIn) - (LOF(FileIn) Mod 3)
  411.     
  412.     For i = 1 To l Step 3
  413.  
  414.         'Read three bytes
  415.         Get FileIn, , bin(0)
  416.         Get FileIn, , bin(1)
  417.         Get FileIn, , bin(2)
  418.         
  419.         'Always wait until there're more then 64 characters
  420.         If Len(s) > 64 Then
  421.  
  422.             s = s & vbCrLf
  423.             sResult = sResult & s
  424.             s = ""
  425.  
  426.         End If
  427.  
  428.         'Calc Base64-encoded char
  429.         b = (bin(n) \ 4) And &H3F 'right shift 2 bits (&H3F=111111b)
  430.         s = s & Base64Tab(b) 'the character s holds the encoded chars
  431.         
  432.         b = ((bin(n) And &H3) * 16) Or ((bin(1) \ 16) And &HF)
  433.         s = s & Base64Tab(b)
  434.         
  435.         b = ((bin(n + 1) And &HF) * 4) Or ((bin(2) \ 64) And &H3)
  436.         s = s & Base64Tab(b)
  437.         
  438.         b = bin(n + 2) And &H3F
  439.         s = s & Base64Tab(b)
  440.         
  441.     Next i
  442.  
  443.     'Now, you need to check if there is something left
  444.     If Not (LOF(FileIn) Mod 3 = 0) Then
  445.  
  446.         'Reads the number of bytes left
  447.         For i = 1 To (LOF(FileIn) Mod 3)
  448.             Get FileIn, , bin(i - 1)
  449.         Next i
  450.     
  451.         'If there are only 2 chars left
  452.         If (LOF(FileIn) Mod 3) = 2 Then
  453.             b = (bin(0) \ 4) And &H3F 'right shift 2 bits (&H3F=111111b)
  454.             s = s & Base64Tab(b)
  455.             
  456.             b = ((bin(0) And &H3) * 16) Or ((bin(1) \ 16) And &HF)
  457.             s = s & Base64Tab(b)
  458.             
  459.             b = ((bin(1) And &HF) * 4) Or ((bin(2) \ 64) And &H3)
  460.             s = s & Base64Tab(b)
  461.             
  462.             s = s & "="
  463.         
  464.         Else 'If there is only one char left
  465.             b = (bin(0) \ 4) And &H3F 'right shift 2 bits (&H3F=111111b)
  466.             s = s & Base64Tab(b)
  467.             
  468.             b = ((bin(0) And &H3) * 16) Or ((bin(1) \ 16) And &HF)
  469.             s = s & Base64Tab(b)
  470.             
  471.             s = s & "=="
  472.         End If
  473.     End If
  474.  
  475.     'Send the characters left
  476.     If s <> "" Then
  477.         s = s & vbCrLf
  478.         sResult = sResult & s
  479.     End If
  480.     
  481.     'Send the last part of the MIME Body
  482.     s = ""
  483.     
  484.     Close FileIn
  485.     EncodeBase64 = sResult
  486.     
  487. End Function
  488.