Option Explicit

'==================================================================
'Created by SCINER: lenar2003@mail.ru
'20/04/2005
'Контрол для отправки писем по SMTP протоколу
'Через сервер требующий SMTP-авторизацию
'==================================================================

Private Const MB_PRECOMPOSED As Long = &H1 ' use precomposed chars
Private Const MB_COMPOSITE As Long = &H2 ' use composite chars
Private Const MB_USEGLYPHCHARS As Long = &H4 ' use glyph chars, not ctrl chars

Event Sent() 'ГЕНЕРИРУЕТСЯ ПОСЛЕ ОТПРАВКИ ПИСЬМА
Event ErrorSend(ByVal Description As String) 'ОШИБКА
Event StatusChange(ByVal Description As String) 'ИЗМЕНЕНИЕ СТАТУСА ОТПРАВКИ ПИСЬМА

Public Enum CodePages
  Win = 1251
  Dos = 866
  Iso = 28595
  Koi8r = 20866
End Enum

'СТАНДАРТНАЯ КОДИРОВКА ЛЯ ТЕЛА ПИСЬМА
Private Const CHARSET As String = "windows-1251" 'iso-8859-1
'МЕТОД КОДИРОВАНИЯ ВЛОЖЕННЫХ ФАЙЛОВ
Private Const FILE_CODE As String = "base64" 'binary, uuCode
Dim bQuit As Boolean
Dim T As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Dim Base64Tab(63) As Byte
Dim DecodeTable(233) As Byte

'КОНСТАНТЫ СОСТОЯНИЙ
  Private Const SMTP_Connecting = "[0/9] Соединение"
  Private Const SMTP_Identifying = "[1/9] Идентификация"
  Private Const SMTP_AuthIdentify = "[2/9] Авторизация"
  Private Const SMTP_AuthUsername = "[3/9] Авторизация логина"
  Private Const SMTP_AuthPassword = "[4/9] Авторизация пароля"
  Private Const SMTP_MailFrom = "[5/9] Установка отправителя"
  Private Const SMTP_RcptTo = "[6/9] Установка получателя"
  Private Const SMTP_BeginBody = "[7/9] Создание письма"
  Private Const SMTP_SendBody = "[8/9] Отправка письма"
  Private Const SMTP_Closing = "[9/9] Закрытие соединения"
  Private Const SMTP_Closed = "Соединение закрыто"

Dim sS                                 As String
Dim ENC                                As Object
Dim Tmr                                As Single
Dim Reply                              As Integer
Dim Start                              As Single
Dim Response                           As String
Dim LastState                          As String
Dim blnSendOK                          As Boolean
Dim sComplemento                       As String
Dim MailToSeparated                    As Collection
Public Busy                            As Boolean

'ДАННЫЕ ПИСЬМА
Public AuthLogin                       As String     'SMTP-ЛОГИН ОТПРАВИТЕЛЯ
Public AuthPassword                    As String     'SMTP-ПАРОЛЬ ОТПРАВИТЕЛЯ
Public Attachments                     As Collection 'ФАЙЛЫ ПРИСОЕДИНЕННЫЕ К ПИСЬМУ
Public MailTo                          As String     'АДРЕС(Ы) ПОЛУЧАТЕЛЯ(ЕЙ)
Public MailFrom                        As String     'АДРЕС ОТПРАВИТЕЛЯ
Public MailFromName                    As String     'ИМЯ ОТПРАВИТЕЛЯ
Public MailToName                      As String     'ИМЯ ПОЛУЧАТЕЛЯ
Public MailSubject                     As String     'ТЕМА ПИСЬМА
Public MailBody                        As String     'ТЕКСТ СООБЩЕНИЯ
Public MailServer                      As String     'SMTP-СЕРВЕР
Public MailServerPort                  As Long       'SMTP-ПОРТ СЕРВЕРА
Public MailPriority                    As Long

'ФУНКЦИИ ДЛЯ ПЕРЕКОДИРОВКИ ТЕКСТА
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As String, ByVal cchMultiByte As Long, ByVal lpWideCharStr As String, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As String, ByVal cchWideChar As Long, ByVal lpMultiByteStr As String, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long

'BASE64 КОДЕР/ДЕКОДЕР
          Private Sub EncodeB64(ByRef FileIn() As Byte, ByRef Out() As Byte)
          'declarations
          Dim Bin(2) As Byte
          Dim iTemp As Long
          Dim i As Long
          Dim Lenght As Long
          Dim Remaining As Byte
          Dim BytesOut As Long
          Lenght = UBound(FileIn) + 1 'lenght of the string
          Remaining = ((Lenght) Mod 3)
          If Remaining = 0 Then
              BytesOut = ((Lenght / 3) * 4)  ' how many bytes will the encoded string have
          Else
              BytesOut = (((Lenght + (3 - Remaining)) / 3) * 4) ' how many bytes will the encoded string have
          End If
          ReDim Out(BytesOut - 1)
          For i = 0 To Lenght - Remaining - 1 Step 3
              '3 bytes in
              Bin(0) = FileIn(i)
              Bin(1) = FileIn(i + 1)
              Bin(2) = FileIn(i + 2)
              '4 bytes out
              Out(iTemp) = Base64Tab((Bin(0) \ 4) And &H3F)
              Out(iTemp + 1) = Base64Tab((Bin(0) And &H3) * 16 Or (Bin(1) \ 16) And &HF)
              Out(iTemp + 2) = Base64Tab((Bin(1) And &HF) * 4 Or (Bin(2) \ 64) And &H3)
              Out(iTemp + 3) = Base64Tab(Bin(2) And &H3F)
              iTemp = iTemp + 4
          Next
          If Remaining = 1 Then ' if there is 1 byte remaining
              'read 1 byte, the second in 0
              Bin(0) = FileIn(UBound(FileIn))
              Bin(1) = 0
              Out(UBound(Out) - 3) = Base64Tab((Bin(0) \ 4) And &H3F)
              Out(UBound(Out) - 2) = Base64Tab((Bin(0) And &H3) * 16 Or (Bin(1) \ 16) And &HF)
              Out(UBound(Out) - 1) = 61
              Out(UBound(Out)) = 61
          ElseIf Remaining = 2 Then 'if there are 2 bytes remaining
              'read 2 bytes, the third is 0
              Bin(0) = FileIn(UBound(FileIn) - 1)
              Bin(1) = FileIn(UBound(FileIn))
              Bin(2) = 0
              Out(UBound(Out) - 3) = Base64Tab((Bin(0) \ 4) And &H3F)
              Out(UBound(Out) - 2) = Base64Tab((Bin(0) And &H3) * 16 Or (Bin(1) \ 16) And &HF)
              Out(UBound(Out) - 1) = Base64Tab((Bin(1) And &HF) * 4 Or (Bin(2) \ 64) And &H3)
              Out(UBound(Out)) = 61
          End If
          End Sub
          Private Sub Str2ByteArray(StringIn As String, ByteArray() As Byte)
              ByteArray = StrConv(StringIn, vbFromUnicode)
          End Sub
          Private Sub Span(CharsPerLine As Long, InArray() As Byte, OutArray() As Byte)
          Dim Lines As Long
          Dim i2 As Long
          Dim i As Long
          Dim TempI As Long
          Lines = ((UBound(InArray) + 1) + (UBound(InArray) + 1) Mod CharsPerLine) / CharsPerLine
          ReDim OutArray(LBound(InArray) To UBound(InArray) + (Lines * 2))
          TempI = 0
          While Not TempI > UBound(InArray)
              For i = TempI To TempI + CharsPerLine - 1
                  If i2 > UBound(OutArray) Or i > UBound(InArray) Then Exit Sub
                  OutArray(i2) = InArray(i)
                  i2 = i2 + 1
              Next
              If i2 > UBound(OutArray) Then Exit Sub
              OutArray(i2) = 13
              OutArray(i2 + 1) = 10
              TempI = TempI + CharsPerLine
              i2 = i2 + 2
          Wend
          End Sub
          Private Sub Unspan(ArrayIn() As Byte, ArrayOut() As Byte)
              Dim sTemp As String
              sTemp = StrConv(ArrayIn, vbUnicode)
              sTemp = Replace(sTemp, vbCrLf, "")
              ArrayOut = StrConv(sTemp, vbFromUnicode)
          End Sub
          'СЛУЖЕБНАЯ ПРОЦЕДУРА РАЗДЕЛЕНИЯ СТРОКИ НА СТРОКИ ДЛИНОЙ  76 СИМВОЛОВ
          Private Function Do76(ByVal slpz As String) As String
            Dim i As Long
            Dim B() As Byte
            Dim C() As Byte
            Dim Pos As Long
            B = StrConv(slpz, vbFromUnicode)
            ReDim C(UBound(B) * 2)
            For i = 0 To UBound(B)
              C(Pos) = B(i): Pos = Pos + 1
              If ((i + 1) Mod 76 = 0) Then
                C(Pos) = 13: Pos = Pos + 1
                C(Pos) = 10: Pos = Pos + 1
              End If
            Next
            ReDim Preserve C(Pos - 1)
            Do76 = StrConv(C, vbUnicode)
            End Function
          'ПЕРЕКОДИРОВКА ФАЙЛА С ИСПОЛЬЗОВАНИЕМ АЛГОРИТМА Base64
          Private Function EncodeFile(ByVal FilePath As String) As String
            Dim FF                                As Long
            Dim B()                               As Byte
            Dim C()                               As Byte
            FF = FreeFile
            Open FilePath For Binary As #FF
              ReDim B(LOF(FF) - 1)
              Get #FF, , B
            Close #FF
            EncodeB64 B, C
            EncodeFile = StrConv(C, vbUnicode)
          End Function
          'ПЕРЕКОДИРОВАНИЕ ИЗ Base64
          Private Sub DecodeB64(ByRef FileIn() As Byte, ByRef Out() As Byte)
          'declarations
          Dim inp(3) As Byte
          Dim iTemp As Long
          Dim i As Long
          Dim Lenght As Long
          Dim Remaining As Byte
          Dim BytesOut As Long
          Dim lTemp2 As Long
          If FileIn(UBound(FileIn)) = 61 Then
              Remaining = 1
              If FileIn(UBound(FileIn) - 1) = 61 Then
                  Remaining = 2
              End If
          End If
          Lenght = UBound(FileIn) + 1 'lenght of the string
          BytesOut = ((Lenght / 4) * 3) - Remaining ' how many bytes will the decoded string have
          ReDim Out(BytesOut - 1)
          For i = 0 To Lenght Step 4
              inp(0) = DecodeTable(FileIn(i))
              inp(1) = DecodeTable(FileIn(i + 1))
              inp(2) = DecodeTable(FileIn(i + 2))
              inp(3) = DecodeTable(FileIn(i + 3))
              If inp(3) = 64 Or inp(2) = 64 Then
                  If inp(3) = 64 And Not (inp(2) = 64) Then
                      inp(0) = DecodeTable(FileIn(i))
                      inp(1) = DecodeTable(FileIn(i + 1))
                      inp(2) = DecodeTable(FileIn(i + 2))
                      '2 bytes out
                      Out(iTemp) = (inp(0) * 4) Or ((inp(1) \ 16) And &H3)
                      Out(iTemp + 1) = ((inp(1) And &HF) * 16) Or ((inp(2) \ 4) And &HF)
                      Exit Sub
                  ElseIf inp(2) = 64 Then
                      inp(0) = DecodeTable(FileIn(i))
                      inp(1) = DecodeTable(FileIn(i + 1))
                      '1 byte out
                      Out(iTemp) = (inp(0) * 4) Or ((inp(1) \ 16) And &H3)
                      Exit Sub
                  End If
              End If
              '3 bytes out
              Out(iTemp) = (inp(0) * 4) Or ((inp(1) \ 16) And &H3)
              Out(iTemp + 1) = ((inp(1) And &HF) * 16) Or ((inp(2) \ 4) And &HF)
              Out(iTemp + 2) = ((inp(2) And &H3) * 64) Or inp(3)
              iTemp = iTemp + 3
          Next
          End Sub



  Private Sub Msg(ByVal Txt As String)
    RaiseEvent StatusChange(Txt)
    End Sub
  Private Property Get smtpState() As String
    smtpState = LastState
  End Property
  Private Property Let smtpState(ByVal vNewValue As String)
    LastState = vNewValue
    RaiseEvent StatusChange(vNewValue)
  End Property

'БЫСТРЫЙ СБРОС ПАРАМЕТРОВ ПИСЬМА
Sub Reset()
  Set Attachments = New Collection
  MailServerPort = 25
  AuthLogin = vbNullString
  AuthPassword = vbNullString
  MailTo = vbNullString
  MailFrom = vbNullString
  MailFromName = vbNullString
  MailToName = vbNullString
  MailSubject = vbNullString
  MailBody = vbNullString
  MailServer = vbNullString
  MailPriority = 3
End Sub

'СОЗДАНИЕ И ОТПРАВКА ПИСЬМА
Sub Send()
  Dim Tmp As String
  Dim TP() As String
  Dim i As Long
  Set MailToSeparated = New Collection
  Tmp = Replace(MailTo, ",", ";")
  Tmp = Replace(Tmp, " ", vbNullString)
  If InStr(Tmp, ";") > 0 Then
    TP = Split(Tmp, ";")
    For i = 0 To UBound(TP)
      If TP(i) Like "*@*.*" Then MailToSeparated.Add TP(i)
    Next
  Else
    Call MailToSeparated.Add(Tmp)
  End If
  Call SendEmail(MailServer, MailFromName, MailFrom, MailToName, Tmp, MailSubject, MailBody)
End Sub
Private Sub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String)
  Winsock1.LocalPort = 0 ' Must Set local port To 0 (Zero) or you can only send 1 e-mail per program start
  'create the message complemente (after DATA)
  sComplemento = CreateMessage(FromName, FromEmailAddress, ToName, ToEmailAddress, EmailSubject, EmailBodyOfMessage)
  Dim lP1 As Long
  Dim lP2 As Long
  lP1 = 50
  If Winsock1.State = sckClosed Then ' Check To see if socet is closed
      Busy = True
      Winsock1.Protocol = sckTCPProtocol ' Set protocol For sending
      Winsock1.RemoteHost = MailServerName ' Set the server address
      Winsock1.RemotePort = MailServerPort ' Set the SMTP Port
      bQuit = True
      Winsock1.Connect ' Start connection
      Do While bQuit
        If (lP2 = lP1) Then
          RaiseEvent ErrorSend("Неудалось отправить письмо, т.к. сервер не отвечает.")
          Busy = False
          smtpState = SMTP_Closed
          Winsock1.CloseSocket
          Exit Do
        End If
        DoEvents
        lP2 = lP2 + 1
        RaiseEvent StatusChange("[" & Format(lP2, "00") & "/" & Format(lP1, "00") & "] Подключение к серверу. Ожидается ответ...")
        Sleep 100
      Loop
  End If
End Sub

Private Sub UserControl_Initialize()
  'СБРОС ПАРАМЕТРОВ ПИСЬМА
  Call Reset
    'ИНИЦИАЛИЗАЦИЯ Base64 ТАБЛИЦЫ
      Dim i As Long
      Dim tDecodeTable As Variant
      tDecodeTable = 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", _
      "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" _
      , "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")
      For i = LBound(tDecodeTable) To UBound(tDecodeTable)
      DecodeTable(i) = tDecodeTable(i)
      Next
      For i = 65 To 90
      Base64Tab(i - 65) = i
      Next
      For i = 97 To 122
      Base64Tab(i - 71) = i
      Next
      For i = 0 To 9
      Base64Tab(i + 52) = 48 + i
      Next
      Base64Tab(62) = 43
      Base64Tab(63) = 47
End Sub

Private Sub UserControl_Resize()
  On Error Resume Next
  Width = 32 * 15
  Height = Width
End Sub

'ВЕСЬ ПРОЦЕСС ОБЩЕНИЯ С СЕРВЕРОМ
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

    Dim B() As Byte
    Dim C() As Byte
    Dim Tmp As String

    bQuit = False
    Winsock1.GetData Response, vbString

    Select Case Val(Mid$(Response, 1, 3))
      Case 220
        smtpState = SMTP_Identifying
        Call SendData("HELO " & Winsock1.LocalHostName & vbCrLf)
      Case 235
        Select Case smtpState
        Case SMTP_AuthPassword
          smtpState = SMTP_MailFrom
          WinsockSendData "MAIL FROM: <" & MailFrom & ">" & vbCrLf
        End Select
      Case 250
        Select Case smtpState
        Case SMTP_Identifying
          If Trim(AuthLogin) <> "" And Trim(AuthPassword) <> "" Then
            smtpState = SMTP_AuthIdentify
            WinsockSendData "AUTH LOGIN" & vbCrLf
          Else
            smtpState = SMTP_MailFrom
            WinsockSendData "MAIL FROM: <" & MailFrom & ">" & vbCrLf
          End If
        Case SMTP_MailFrom
            WinsockSendData "RCPT TO:<" & MailToSeparated.Item(1) & ">" & vbCrLf
            Call MailToSeparated.Remove(1)
            smtpState = IIf(MailToSeparated.Count > 0, SMTP_MailFrom, SMTP_RcptTo)
        Case SMTP_RcptTo
            smtpState = SMTP_BeginBody
            WinsockSendData "DATA" & vbCrLf
        Case SMTP_SendBody
            smtpState = SMTP_Closing
            WinsockSendData "QUIT"
            Winsock1.CloseSocket
            smtpState = SMTP_Closed
            blnSendOK = True
            RaiseEvent Sent
        End Select
      Case 251
        Select Case smtpState
        Case SMTP_RcptTo
          smtpState = SMTP_BeginBody
          WinsockSendData "DATA" & vbCrLf
        End Select
      Case 334
        Select Case smtpState
        'ОТПРАВКА ЛОГИНА
        Case SMTP_AuthIdentify
          smtpState = SMTP_AuthUsername
          B = StrConv(AuthLogin, vbFromUnicode)
          Call EncodeB64(B, C)
          Tmp = StrConv(C, vbUnicode)
          WinsockSendData Tmp & vbCrLf
        'ОТПРАВКА ПАРОЛЯ
        Case SMTP_AuthUsername
          smtpState = SMTP_AuthPassword
          B = StrConv(AuthPassword, vbFromUnicode)
          Call EncodeB64(B, C)
          Tmp = StrConv(C, vbUnicode)
          WinsockSendData Tmp & vbCrLf
        End Select
      Case 354
        smtpState = SMTP_SendBody
        Call SendData(sComplemento)
        Call SendData(vbCrLf & "." & vbCrLf)
      Case Is >= 400
        RaiseEvent ErrorSend(Response)
        smtpState = SMTP_Closed
        Winsock1.CloseSocket
      Case Else
        smtpState = SMTP_Closed
        Winsock1.CloseSocket
      End Select

End Sub

'ПИСЬМО ЦЕЛИКОМ ПРОХОДИТ ЧЕРЕЗ ЭТУ ПРОЦЕДУРУ
Private Function SendData(sText As String)
    Call ToLog(sText)
    Winsock1.SendData sText
End Function

Sub WinsockSendData(ByVal strMsg As String)
  Winsock1.SendData strMsg
End Sub

'МОЖНО ПО ПУТИ СОХРАНЯТЬ "ИСХОДНИК" ПИСЬМА
Private Sub ToLog(ByVal sString As String)
  'Open "c:\sendmail.txt" For Append As #11
  '  Print #11, sString
  'Close #11
End Sub

Private Function FastB64Encode(ByVal strBuf As String) As String
  Dim B() As Byte
  Dim C() As Byte
  B = StrConv(strBuf, vbFromUnicode)
  EncodeB64 B, C
  FastB64Encode = StrConv(C, vbUnicode)
End Function

'СОЗДАНИЕ "ИСХОДНИКА СООБЩЕНИЯ"
Private Function CreateMessage(FromName As String, _
                        FromEmailAddress As String, _
                        ToName As String, _
                        ToEmailAddress As String, _
                        EmailSubject As String, _
                        EmailBodyOfMessage As String) As String

  'ЗДЕСЬ ИСПОЛЬЗУЕТСЯ СКЛЕИВАНИЕ ПЕРЕМЕННЫХ
  'КТО-ТО МОЖЕТ СКАЗАТЬ ЧТО ЭТО ОЧЕНЬ МЕДЛЕННО
  'НО ЭТО ТОЛЬКО ТАК КАЖЕТСЯ, НА САМОМ ДЕЛЕ ЗДЕСЬ ОЧЕНЬ МАЛО ТОЧЕК СКЛЕИВАНИЯ,
  'ПОЭТОМУ ДАННЫЙ КОД НЕ СНИЖАЕТ ОБЩЕЙ ПРОИЗВОДИТЕЛЬНОСТИ АЛГОРИТМА

  'ЗДЕСЬ НЕПРАВИЛЬНО ЛИШЬ ТО, ЧТО ЭТОТ МЕТОД НЕ РАСЧИТАН НА ФАЙЛЫ
  'РАЗМЕРОМ В НЕСКОЛЬКО ДЕСЯТКОВ МЕГАБАЙТ!
  'Т.К. ЗДЕСЬ ПОТРЕБУЕТСЯ ТАКОЙ ОБЪЕМ ОПЕРАТИВНОЙ ПАМЯТИ
  'СКОЛЬКО ВЕСЯТ ВСЕ ВЛОЖЕННЫЕ ФАЙЛЫ * 1.3
  'Т.К. ОНИ ЕЩЕ ПЕРЕКОДИРУЮТСЯ ПО АЛГОРИТМУ Base64
  Dim i                                As Integer

  'ЗАГОЛОВОК ПИСЬМА
  sS = vbNullString
 'sS = sS & "X-Originating-IP: [x.x.x.x]" & vbCrLf
            'X-Originating-Email: [user@domain.ru]
            'X-Sender: user@domain.ru
  sS = sS & "X-Priority: " & VBA.Trim$(MailPriority) & vbCrLf
  sS = sS & "From: =?windows-1251?B?" & FastB64Encode(FromName) & "?= <" & FromEmailAddress & " > " & vbCrLf
  sS = sS & "To: " & ToEmailAddress & vbCrLf
  sS = sS & "Subject: =?windows-1251?B?" & FastB64Encode(EmailSubject) & "?=" & vbCrLf
  sS = sS & "Date: " & Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & " -0300" & vbCrLf
  sS = sS & "MIME-Version: 1.0" & vbCrLf
  sS = sS & "Content-Type: multipart/mixed;" & vbCrLf
  sS = sS & vbTab & "boundary=""" & "----=_NextPart_000_000C_01C21C67F3F2CCA0" & """" & vbCrLf
  sS = sS & vbCrLf
  sS = sS & "This is a multi-part message in MIME format." & vbCrLf
  sS = sS & vbCrLf
  sS = sS & "------=_NextPart_000_000C_01C21C67F3F2CCA0" & vbCrLf
  sS = sS & "Content-Type: text/plain;" & vbCrLf
  sS = sS & vbTab & "charset=""" & CHARSET & """" & vbCrLf
  sS = sS & "Content-Transfer-Encoding: 7bit" & vbCrLf
  sS = sS & vbCrLf
  sS = sS & EmailBodyOfMessage & vbCrLf
  sS = sS & vbCrLf

  'КОДИРУЕМ ВЛОЖЕННЫЕ ФАЙЛЫ ПИСЬМА
  For i = 1 To Attachments.Count
      sS = sS & "------=_NextPart_000_000C_01C21C67F3F2CCA0" & vbCrLf
      sS = sS & "Content-Type: application/octet-stream;" & vbCrLf
      sS = sS & vbTab & "name=""" & Dir(Attachments.Item(i)) & """" & vbCrLf
      sS = sS & "Content-Transfer-Encoding: " & FILE_CODE & vbCrLf
      sS = sS & "Content-Disposition: attachment;" & vbCrLf
      sS = sS & vbTab & "filename=""" & Dir(Attachments.Item(i)) & """" & vbCrLf
      sS = sS & vbCrLf
      sS = sS & Do76(EncodeFile(Attachments.Item(i))) & vbCrLf
  Next

  sS = sS & vbCrLf
  sS = sS & "------=_NextPart_000_000C_01C21C67F3F2CCA0--" & vbCrLf
  CreateMessage = sS

End Function

Public Function Convert(ByVal strSrc As String, ByVal nFromCP As CodePages, ByVal nToCP As CodePages) As String
  Dim nLen As Long
  Dim strDst As String
  Dim strRet As String
  Dim nRet As Long
  nLen = VBA.Len(strSrc)
  strDst = VBA.Space$(nLen * 2)
  strRet = VBA.Space$(nLen * 2)
  nRet = MultiByteToWideChar(nFromCP, MB_PRECOMPOSED, strSrc, nLen, strDst, nLen)
  nRet = WideCharToMultiByte(nToCP, 0, strDst, nRet, strRet, nLen * 2, ByVal 0, 0)
  Convert = VBA.Left$(strRet, nRet)
  End Function