Авторские программы, библиотеки, надстройки и шаблоны

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    CallTarget Target
End Sub

Option Explicit
Global Const mxCn = 5, mxRo = 12, mxB = 5, AppName = "Мультиотправка почты", defM = "Admin@mail.ru"
 
 
Function CDO(user$, pass$, mailTo$, Subj$, text$, Attachments)
 
    Const ur = "http://schemas.microsoft.com/cdo/configuration/"
    Dim smtp$, m As Object, c As Object, v
    On Error Resume Next
    Set m = CreateObject("CDO.Message")
    Set c = CreateObject("CDO.Configuration"): c.Load -1:
    
    
    smtp = "smtp." & LCase(Split(user, "@")(1))
    With c.Fields 'Заполнение полей
        .Item(ur & "smtpusessl") = True 'Secure Sockets Layer (SSL) Указывает что следует использовать при отправке сообщений с использованием протокола SMTP по сети
        .Item(ur & "smtpauthenticate") = 1 'Определяет механизм аутентификации используя TCP / IP сеть.
        .Item(ur & "sendusername") = user 'Имя пользователя
        .Item(ur & "sendpassword") = pass 'Пароль пользователя
        .Item(ur & "smtpserver") = smtp 'ip или DNS-имя smtp-сервера например: yandex.ru
        .Item(ur & "sendusing") = 2 'посылать сообщения по сети (используя SMTP)
        .Item(ur & "smtpserverport") = 465 'Порт с шифрованием SSL для яндекс, гугл, mail.ru, rambler
        .Item(ur & "smtpusessl") = 1  'использовать аутентификацию: да
        .Update
    End With
    With m
        Set .Configuration = c 'Назначаем ссылку на созданную конфигурацию (Fields-поля)
        .To = mailTo 'Получатель
        .From = user 'Отправитель
        .cc = "" 'Копия
        .BCC = "" 'Скрытая копия
        .Subject = Subj 'Заголовок сообщения (тоесть тема)
        .BodyPart.Charset = "UTF-8" 'Устанавливаем в тело Юникод - "UTF-8"
        .TextBody = text 'Текст сообщение
        If IsArray(Attachments) Then 'Добавление вложений
            For Each v In Attachments: .AddAttachment v: Next
        End If
        Err.Clear
        .Send '-Комманда отправки
    End With
    Select Case Err.Number
    Case 0: CDO = "Отправленно"
    Case -2147220973: CDO = "Не отправленно - Отсутствует связь с интернетом"
    Case -2147220975: CDO = "Не отправленно - SMTP сервер ответил отказом"
    Case Else: CDO = "Не отправленно - Код ошибки: " & Err.Number
    End Select
 
End Function
 
Sub Master()
 
    Dim i&, j&, s$, u$, p$, v
    ReDim mas$(3)
    For Each v In Array("адрес получателя:", "тему:", "текст:")
        i = i + 1
        s = InputBox("Добавить " & v, AppName, Choose(i, defM, "тест", "hello !")): Do While s = "": Exit Sub: Exit Do: Loop: mas(i) = s
        
    Next
    AddAttachments
    
    GetAcount u, p: If InStr(1, u, "@") = 0 Or Len(p) < 2 Then If CreateAcount = False Then Exit Sub
 
    Optimize True
    With Range("A2:C" & mxRo - 2): .Cut Destination:=Range("A3:C" & mxRo - 1): End With
    
    Cells(2, 1).Hyperlinks.Add Anchor:=Cells(2, 1), Address:="mailto:" & mas(1), TextToDisplay:=mas(1)
    
    For i = 2 To 3: Cells(2, i).Value = mas(i): Next
    [a2].Select
    Optimize 0
End Sub
 
 
Sub AddAttachments()
    Dim i&, j&, v, files
    files = Application.GetOpenFilename("Файлы Excel(*.xls*),*.xls* ,Текстовые файлы(*.txt),*.txt* ,Любые файлы, *.*", 3, "Выберите файл(ы) для отправки", , True)
    If IsArray(files) Then
        j = mxCn - 1
        i = Cells(Rows.Count, j).End(xlUp).Row + 1
        For Each v In files
            With Cells(i, j)
                i = i + 1: .Value = v
            End With
        Next
    End If
End Sub
 
Sub Send()
    Dim i&, j&, att, u$, p$, v, mailTo$, s$
    Dim coll As New Collection
    j = mxCn - 1
    On Error Resume Next
    For i = 2 To Cells(Rows.Count, j).End(xlUp).Row: coll.Add Cells(i, j).Value: Next
    If coll.Count > 0 Then
        att = Array(): ReDim Preserve att(coll.Count - 1)
        For i = 1 To coll.Count: att(i - 1) = coll(i): Next
    End If
    GetAcount u, p: If InStr(1, u, "@") = 0 Or Len(p) < 2 Then If CreateAcount = False Then Exit Sub
    If InStr(1, Cells(2, 1).Value, "@") = 0 Then Master
    j = 1: s = Chr(96 + mxCn)
    Range(s & 2 & ":" & s & mxRo - 1).ClearContents
    For i = 2 To mxRo - 1
        mailTo = Cells(i, 1).Value
        If InStr(1, mailTo, "@") = 0 Then Exit For
        Cells(i, mxCn).Value = CDO(u, p, mailTo, Cells(i, 2).Value, Cells(i, 3).Value, att)
    Next
    MsgBox "Готово"
End Sub
 
Function CreateAcount() As Boolean
    Dim u$, p$, s$
    GetAcount u, p
    If Len(u) = 0 Then u = defM
    s = InputBox("Введите почтовый адрес отправителя:", AppName, u): Do While s = "": Exit Function: Exit Do: Loop: u = s
    s = InputBox("Введите пароль отправителя:", AppName, p): Do While s = "": Exit Function: Exit Do: Loop: p = s
    If InStr(1, u, "@") > 1 Then SaveSetting AppName, "mail", "sendusername", u Else Exit Function
    If Len(p) > 1 Then SaveSetting AppName, "mail", "sendpassword", p Else Exit Function
    CreateAcount = True
End Function
 
 
Sub GetAcount(sendusername$, sendpassword$)
    sendusername = GetSetting(AppName, "mail", "sendusername", "")
    sendpassword = GetSetting(AppName, "mail", "sendpassword", "")
End Sub
 
Sub CallTarget(ByVal Target As Range):  On Error Resume Next
 
    Static old As Object: Do While old Is Nothing: Set old = Cells(1, 1): Exit Do: Loop
    If Target.Row >= mxRo And Target.Row <= (mxRo + mxB - 1) And Target.Column = 1 Then
        old.Select
        Select Case Target.Row - mxRo
        Case 0: Send
        Case 1: Master
        Case 2: CreateTable
        Case 3: AddAttachments
        Case 4: CreateAcount
        End Select
    Else: Set old = Target
    End If
End Sub
 
 
Sub CreateTable()
    Dim i&, v
    
    ActiveWorkbook.Sheets(1).Activate
    Optimize True
    With Range("A:" & Chr(96 + mxCn))
        .ClearContents
        .ColumnWidth = 24
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .ShrinkToFit = True
    End With
 
    With Range("a1:" & Chr(96 + mxCn) & 1)
        For i = 7 To 12
            
            .Interior.ColorIndex = 48
            With .Borders(i)
                .Weight = xlThin
            End With
        Next
        For i = 1 To .Columns.Cells.Count
           With .Cells(1, i)
                .Value = Choose(i, "Кому:", "Тема:", "Текст:", "Вложения:", "Отчет:")
                .Font.Bold = 1
                .HorizontalAlignment = xlCenter
           End With
        Next
    End With
    
 
    v = "a" & mxRo & ":" & "a" & (mxRo + mxB - 1)
    Range(v).EntireRow.Delete
 
    With Range(v)
        .RowHeight = 20
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Bold = 1
        .Interior.ColorIndex = 45
        On Error Resume Next
        For i = 7 To 12
            With .Borders(i)
                .LineStyle = xlDouble
                .Weight = xlThick
            End With
        Next
        For i = 1 To .Columns.Cells.Count
           With .Cells(i, 1)
                .Value = Choose(i, "Отправить", "Создать сообщение", "Форматировать", "Добавить вложение", "Аккаунт")
                If i Mod 2 = 0 Then .Interior.ColorIndex = 4
           End With
        Next
    End With
    Optimize False
End Sub
 
 
Sub Optimize(ByVal act As Boolean)
    With Application
        If act = True Then
            .ScreenUpdating = False 'отключаем обновление экрана
            .Calculation = xlCalculationManual 'Отключаем автопересчет формул
            .EnableEvents = False 'Отключаем отслеживание событий
        Else
            .ScreenUpdating = True 'Возвращаем обновление экрана
            .Calculation = xlCalculationAutomatic 'Возвращаем автопересчет формул
            .EnableEvents = True 'Включаем отслеживание событий
        End If
    End With
End Sub

Option Explicit
'
'Мастер создания кнопки с градиентом
'by the fever.brain
'
Sub AeroButtonStart()
    '
    'Автоматическое перенаправление команды на соответствующее имя кнопки
    '
    On Error Resume Next
    With ActiveSheet.Shapes(Application.Caller)
        .Visible = 1
        Application.Run .Name 'Макрос будет вызываться по имени кнопки
    End With
End Sub
 
Sub AeroButton1(): Msg "AeroButton1": End Sub
Sub AeroButton2(): Msg "AeroButton2": End Sub
Sub AeroButton3(): Msg "AeroButton3": End Sub
Sub AeroButton4(): Msg "AeroButton4": End Sub
Sub AeroButton5(): Msg "AeroButton5": End Sub
 
Sub Msg(text)
    On Error Resume Next
    MsgBox "Имя выполненного макроса: " & text & vbLf & "Текст на кнопке: " & _
    ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.text, vbInformation
End Sub
 
 
Sub AeroButton()
    Const def = "AeroButton": Dim r As Range, sh As Shape, v, tx$, lc&
    On Error Resume Next
    Static wsh As Object: Do While wsh Is Nothing: Set wsh = CreateObject("WScript.Shell"): Exit Do: Loop
    Set r = Application.InputBox("Введите диапазон", , Selection.Address, Type:=8): If Err.Number > 0 Then Exit Sub
    Set sh = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, r.Left, r.Top, r.Width, r.Height)
    With sh
        For lc = 0 To &H7FFFFFFF: Err.Clear: tx = def & IIf(lc, lc, ""): tx = ActiveSheet.Shapes(tx).Name: Do While Err: Exit For: Exit Do: Loop: Next: .Name = tx
        Do While lc = 0: ActiveWorkbook.Colors(10) = vbGreen: Exit Do: Loop
        tx = IIf(lc, "Кнопка " & lc, "Создать кнопку") 'Создание имени и названия
        .Fill.Visible = msoTrue: .Fill.Solid: .Fill.Transparency = 0.3: .Fill.BackColor.RGB = vbWhite
        .Fill.ForeColor.RGB = ActiveWorkbook.Colors(10): .Line.Weight = 0#: .Line.ForeColor.SchemeColor = 22
        .OnAction = .OnAction
        If Application.Dialogs(xlDialogEditColor).Show(10) Then 'Выбор цвета
            .Fill.ForeColor.RGB = ActiveWorkbook.Colors(10): .OnAction = .OnAction
        End If
        .Fill.TwoColorGradient msoGradientHorizontal, 2
        .Adjustments.Item(1) = 0.23: .Placement = xlFreeFloating
        .OLEFormat.Object.PrintObject = False
        With .TextFrame ' текст
            .Characters.text = InputBox("Введите название кнопки", "Создание кнопки", tx)
            With .Characters.Font ' изменяем начертание текста
                .Size = 10: .Bold = True: .Color = vbBlack: .Name = "Arial" ' цвет и шрифт
            End With
            .HorizontalAlignment = xlCenter: .VerticalAlignment = xlVAlignCenter
        End With
        .OnAction = "AeroButtonStart" 'Назначение макроса
        If wsh.Popup("Назначеный макрос: " & .OnAction, 3, "Назначение макроса", 65) = vbCancel Then
            .Select: Application.Dialogs(xlDialogAssignToObject).Show
        End If
    End With
End Sub