Форум программистов, компьютерный форум, киберфорум
Наши страницы
VBA
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 2, средняя оценка - 5.00
аналитика
здесь больше нет...
3349 / 1664 / 184
Регистрация: 03.02.2010
Сообщений: 1,219
#1

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

12.02.2010, 17:42. Просмотров 117971. Ответов 153
Метки нет (Все метки)

 Комментарий модератора 
Коллектив модераторов раздела оставляет за собой право использовать данный пост аналитики для размещения и обновления оглавления темы.

Оглавление
- по тематике:

Утилиты


Инструменты программиста

Графические редакторы



Защита программного кода

Офисные операции

Веб-сервис


Игры




- по автору:
A-Z





Конец оглавления

Оригинальное сообщение от аналитики:

Надстройка для VBE "IndenterVBA" - позволяет редактировать стиль оформления программного кода.
27
Вложения
Тип файла: rar IndenterVBA.rar (253.1 Кб, 1524 просмотров)
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
12.02.2010, 17:42
Я подобрал для вас темы с готовыми решениями и ответами на вопрос Авторские программы, библиотеки, надстройки и шаблоны (VBA):

Подключение библиотеки в коде программы
Добрый день, уважаемые форумчане. При переносе макроса из 2003 в 2007 Excel...

Надстройки
Доброго времени суток, форумчане! Подскажите, каким образом можно извлечь...

Временно отключить надстройки
Здравствуйте! Необходимо в начале действия макрос отключить (или...

Редактирование надстройки EXCEL
Ситуация: есть файл start.xla (при запуске сам не показывается, а формирует и...

Ошибка в коде надстройки
Надстройка выдает ошибку 13. В коде ругается на строку: prob =...

Хранение картинок в теле надстройки
Добрый день! Возможно ли хранить картинку в самом файле ("надстрока.xlsx") и...

153
Владимир_Сар
58 / 57 / 13
Регистрация: 10.09.2009
Сообщений: 255
26.09.2017, 10:09 #141
В цветном виде и с возможностью вернуть ход
Цифра Цветная.xls
0
Zheka_VEYDER
0 / 1 / 0
Регистрация: 29.09.2017
Сообщений: 10
01.10.2017, 19:45 #142
Да, макрос действительно орегинальный!

Добавлено через 7 минут
Цитата Сообщение от fever brain Посмотреть сообщение
Посмотрите, тут тоже без длл и прочей ерунды простая реализация календаря на форме
Реализованно почти 2 года назад http://www.cyberforum.ru/vba/thread1353291.html
Прикольная реализация, спасибо.
0
Dmitrii_Mas
0 / 0 / 0
Регистрация: 14.09.2017
Сообщений: 24
12.10.2017, 22:34 #143
отличная штука!
А доступ к коду возможен?
0
fever brain
oh my god
1101 / 575 / 108
Регистрация: 05.01.2016
Сообщений: 1,769
Записей в блоге: 7
03.11.2017, 21:24 #144
Архивация подпапок в определенной папке, с учетом исключений + установка пароля с пробелом


Автор: fever.brain


Топик:



1
fever brain
oh my god
1101 / 575 / 108
Регистрация: 05.01.2016
Сообщений: 1,769
Записей в блоге: 7
15.02.2018, 00:20 #145
Работа с почтой из Excel
Отправка сообщений с множеством вложений
с использованием CDO.Message

Автор: fever brain


На листе кнопок нет, нужно будет кликнуть на соответствующую команду
количество записей регулируется глобальной переменной mxRo
при добавлении новой записи, прежние смещаются вниз до указанного значения

Тема письма и текст привязан к получателю отдельно
но список вложений не привязан к одной записи
тоесть вложения поступят на все ящики из списка получателей

Если будут вопросы и предложения просьба оставлять их в этой теме


Кликните здесь для просмотра всего текста


Для листа-1
Visual Basic
1
2
3
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    CallTarget Target
End Sub
Для модуля
Visual Basic
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
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
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
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




в почтовике:
Кликните здесь для просмотра всего текста
2
Вложения
Тип файла: xls Почта.xls (76.5 Кб, 16 просмотров)
fever brain
oh my god
1101 / 575 / 108
Регистрация: 05.01.2016
Сообщений: 1,769
Записей в блоге: 7
17.02.2018, 12:49 #146
Градиентная кнопка

Макрос для создания кнопок с градиентной заливкой
с использованием встроенных диалогов

Автор: fever brain


Модуль книги:
Кликните здесь для просмотра всего текста
Visual Basic
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
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
52
53
54
55
56
57
58
59
60
61
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



Excel 2003


Excel 2007
2
Вложения
Тип файла: xls Buttons.xls (41.5 Кб, 7 просмотров)
Тип файла: rar Видео_2018-02-17_175718.rar (509.7 Кб, 7 просмотров)
Dragokas
Эксперт WindowsАвтор FAQ
16927 / 7012 / 852
Регистрация: 25.12.2011
Сообщений: 10,808
Записей в блоге: 16
01.03.2018, 00:02 #147
Скрипт конвертирования статьи из Word на форум

Ссылка на код.

Описание:
Позволяет вставить текст MS Word на любой форум с сохранением форматирования.
В MS Word удобно (мне) готовить статьи и всё такое прочее.

Макрос настроен для моих нужд, если у Вас более наполеоновские аппетиты, попросите меня - я подкорректирую, что нужно.

Вот что он сейчас умеет заменять на BB-код:

- заменяет размеры шрифта MS Word (10, 12, 14, и 16-й). По-умолчанию, сделано так, чтобы не заменял 12-й шрифт (он выбран у меня как основной для всех документов).
- заменяет гиперссылки
- жирность
- курсив
- цвет красный
- цвет синий
- центрирование
- и любые комбинации этих форматов

Как это работает в целом:
1) Открываете Ваш документ с крутым оформлением, запускаете в нем макрос (ALT + F8, выполнить)
2) Копируете результат в любой простой редактор (блокнот Windows подойдет, можно и Akelpad, N++, и т.п.)
3) Копируете из блокнота текст в редактор любого форума. Победа!
1
Вложения
Тип файла: doc test.doc (49.0 Кб, 2 просмотров)
Catstail
Модератор
23540 / 11650 / 2036
Регистрация: 12.02.2012
Сообщений: 18,994
06.03.2018, 21:07 #148
Когда-то давно, я опубликовал надстройку BobServ.xla . Предлагаю доработанную версию. Добавлена функция, облегчающая построение поверхности, заданной функцией двух переменных.

Выбираем прямоугольную область. В ее левый верхний угол записываем формулу поверхности (как текст, без предваряющего знака равенства; рис.1). Далее устанавливаем в верхнем горизонтальном ряду диапазона набор значений x,
а в левом вертикальном - набор значений y. Теперь выделяем весь диапазон, заходим в меню надстройки, выбираем "полезный сервис" -> "установить формулы" (рис. 2). Диапазон заполняется значениями. Теперь можно вставлять диаграмму (рис. 3).

Новая версия BobServ.xla
4
Миниатюры
Авторские программы, библиотеки, надстройки и шаблоны   Авторские программы, библиотеки, надстройки и шаблоны   Авторские программы, библиотеки, надстройки и шаблоны  

Dragokas
Эксперт WindowsАвтор FAQ
16927 / 7012 / 852
Регистрация: 25.12.2011
Сообщений: 10,808
Записей в блоге: 16
11.03.2018, 21:20 #149
Ariawase.xlsm - Контроль версий (SVN) для VBA.

https://github.com/vbaidiot/Ariawase

Довольно любопытный набор функций.

Там есть классы для вызова функций по указателю, доступа к объектной модели, работа с массивами, вроде сериализации, работа с файлами, строками, датами, и другие полезняшки.

Описания нет, так что дерзайте ))

Добавлено через 3 минуты
P.S. По этой ссылке более дополненный форк. И даже ссылки на описание есть (на японском )

Там пишется, что его проект предназначен в основном для экспорта/импорта кода VBA с целью подключения к системе контроля версий и удобной возможности редактировать исходный код в любом другом редакторе.
0
fever brain
oh my god
1101 / 575 / 108
Регистрация: 05.01.2016
Сообщений: 1,769
Записей в блоге: 7
05.04.2018, 15:38 #150
Суррогат Progress Bar


Топик


0
bedvit
406 / 143 / 16
Регистрация: 20.05.2016
Сообщений: 583
Записей в блоге: 6
05.04.2018, 16:05 #151
Библиотеки MPIR, Edition 3.0.0. в COM (скриптовые языки, VBA, да и почти все..) и в .XLL (Excel)
Собрал версии х32 и х64.
Топик
2
Миниатюры
Авторские программы, библиотеки, надстройки и шаблоны   Авторские программы, библиотеки, надстройки и шаблоны  
fever brain
05.04.2018, 16:24
  #152

Не по теме:

Топик не открывался, теперь работает удалите мои писульки

0
fever brain
oh my god
1101 / 575 / 108
Регистрация: 05.01.2016
Сообщений: 1,769
Записей в блоге: 7
21.04.2018, 16:22 #153
VBA таймер с использованием Sleep и TabStrip

в программе реализованна возможность отвечать на вопросы
с ограничением времини 60 секунд, показ убывающего времени

Топик


0
Dragokas
21.04.2018, 16:27     Авторские программы, библиотеки, надстройки и шаблоны
  #154

Не по теме:


fever brain, я вам выше уже писал, что в VBA не нужен таймер, замораживающий программу. В нём есть свои встроенные функции, работающие в отдельном потоке.

0
21.04.2018, 16:27
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
21.04.2018, 16:27
Привет! Вот еще темы с ответами:

Вызов надстройки через VBA
Здравствуйте. Очень нужна Ваша помощь. Задача следующая: В VBA для Excel...

Добавление надстройки Excel в Ribbon
Здравствуйте. Написал я две надстройки на VBA для Excel, и захотелось мне...

Всё про надстройки .XLA
Предлагаю в этой теме обсудить все аспекты надстроек .XLA . Частично эти...

Вызов окна функции из надстройки
Добрый день. Сделал надстройку типа RIBBON. В меню перечислил свои...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
154
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2018, vBulletin Solutions, Inc.
Рейтинг@Mail.ru