Option Explicit

'---------------------------------------------------------------------------------------
' Procedure : Save_File
' Purpose   : Ïðîöåäóðà ñîõðàíåíèÿ ôàéëà
'---------------------------------------------------------------------------------------
'Sub Save_File()
'Dim ActiveSht As Worksheet
'Dim NewWb As Workbook
'
'    Set ActiveSht = ActiveSheet
'    Set NewWb = Workbooks.Add
'    ActiveSht.Copy Before:=Workbooks(NewWb.Name).Sheets(1)
'    With ActiveSheet.UsedRange
'        .Value = .Value
'    End With
'    ActiveWorkbook.SaveAs Filename:=[Q5]
'    MsgBox "Ôîðìà ñêîïèðîâàíà è ñîõðàíåíà", , ""
'End Sub

Sub Save_File()
    Dim WorkDir, WorkDate
    Dim WorkFile As String
    WorkDir = [Q4]
    WorkFile = [Q5]
    Columns("A:O").Select
    Range("A3").Activate
    Selection.Copy
    Workbooks.Add
    Columns("A:A").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Sheet2").Select
    Application.CutCopyMode = False
    ActiveWindow.SelectedSheets.Delete
    Sheets("Sheet3").Select
    ActiveWindow.SelectedSheets.Delete
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = [E2]
    Cells.Select
    Selection.Interior.ColorIndex = xlNone
    Selection.Font.ColorIndex =  0 
    Range("I7").Select
'    ChDir = WorkDir
    ActiveWorkbook.SaveAs Filename:=WorkFile, _
    FileFormat:=xlNormal, _
    Password:="", _
    WriteResPassword:="", _
    ReadOnlyRecommended:=False, _
    CreateBackup:=False
    ActiveWindow.Close
    MsgBox "Ôàéë îò÷åòà ñîõðàíåí!", , "Îïåðàöèÿ çàâåðøåíà"
    Range("A1:M1").Select
End Sub

'---------------------------------------------------------------------------------------
' Procedure : Send_Mail
' Purpose   : Ïðîöåäóðà îòïðàâêè ïèñüìà
'---------------------------------------------------------------------------------------
Sub Send_Mail()
    Const CDO_Cnf = "http://schemas.microsoft.com/cdo/configuration/"
    Dim oCDOCnf As Object, oCDOMsg As Object
    Dim SMTPserver As String, sUsername As String, sPass As String, sMsg As String
    Dim sTo As String, sFrom As String, sSubject As String, sBody As String, sAttachment As String
    On Error Resume Next
    'sFrom - êàê ïðàâèëî ñîâïàäàåò ñ sUsername
    SMTPserver = [Q10]    ' SMTPServer: íàéòè ïîäõîäÿùèé ñåðâåð
    sUsername = [Q11]   ' Ó÷åòíàÿ çàïèñü íà ñåðâåðå
    sPass = [Q12]    ' Ïàðîëü ê ïî÷òîâîìó àêêàóíòó

    If Len(SMTPserver) =  0  Then MsgBox "Íå óêàçàí SMTP ñåðâåð", vbInformation, "Îøèáêà": Exit Sub
    If Len(sUsername) =  0  Then MsgBox "Íå óêàçàíà ó÷åòíàÿ çàïèñü", vbInformation, "Îøèáêà": Exit Sub
    If Len(sPass) =  0  Then MsgBox "Íå óêàçàí ïàðîëü", vbInformation, "Îøèáêà": Exit Sub

    sTo = [Q8]    'Êîìó
    sFrom = [Q9]    'Îò êîãî
    sSubject = [A1]    'Òåìà ïèñüìà
    sBody = [Q3]    'Òåêñò ïèñüìà
    sAttachment = [Q5]    'Âëîæåíèå(ïîëíûé ïóòü ê ôàéëó)
    'Ïðîâåðêà íàëè÷èÿ ôàéëà ïî óêàçàííîìó ïóòè
    If Dir(sAttachment, vbDirectory) = "" Then sAttachment = ""
    'Íàçíà÷àåì êîíôèãóðàöèþ CDO
    Set oCDOCnf = CreateObject("CDO.Configuration")
    With oCDOCnf.Fields
        .Item(CDO_Cnf & "sendusing") =  2 
        .Item(CDO_Cnf & "smtpauthenticate") =  1 
        .Item(CDO_Cnf & "smtpserver") = SMTPserver
        .Item(CDO_Cnf & "smtpserverport") =  465 
        .Item(CDO_Cnf & "smtpusessl") =  1 
        .Item(CDO_Cnf & "sendusername") = sUsername
        .Item(CDO_Cnf & "sendpassword") = sPass
        .Update
    End With
    'Ñîçäàåì ñîîáùåíèå
    Set oCDOMsg = CreateObject("CDO.Message")
    With oCDOMsg
        Set .Configuration = oCDOCnf
        .BodyPart.Charset = "koi8-r"
        .From = sFrom
        .To = sTo
        .Subject = sSubject
        .TextBody = sBody
        If Len(sAttachment) >  0  Then .AddAttachment sAttachment
        .Send
    End With

    Select Case Err.Number
    Case - 2147220973 : sMsg = "Íåò äîñòóïà ê Èíòåðíåò"
    Case - 2147220975 : sMsg = "Îòêàç ñåðâåðà SMTP"
    Case  0 : sMsg = "Îò÷åò îòïðàâëåí!"
    End Select
    MsgBox sMsg, vbInformation, "Îòïðàâêà ñîîáùåíèÿ"
    Set oCDOMsg = Nothing: Set oCDOCnf = Nothing
End Sub

'---------------------------------------------------------------------------------------
' Procedure : Get_File_Path
' Purpose   : Ïðîöåäóðà âûáîðà ôàéëà
'---------------------------------------------------------------------------------------
'Sub Get_File_Path()
'    Dim sPath
'    sPath = Application.GetOpenFilename("All Files(*.*),*.*", , "Âûáðàòü ôàéëû", "Âûáðàòü", False)
'    If sPath = False Then Exit Sub
'    [Q5] = sPath
'End Sub