update
continuous-integration/drone/push Build is passing Details

pull/6/head
thest1tch 2 years ago
parent 3b4acb7b49
commit 1d3639d345

@ -0,0 +1,38 @@
Собрал несколько настроек для docker-compose, чтобы проверять работоспособность различных баз данных
## MySQL / MariaDB
```yaml
healthcheck:
test: out=$$(mysqladmin ping -h 127.0.0.1 -P 3306 -u root --password=$$(cat $${MARIADB_ROOT_PASSWORD_FILE}) 2>&1); echo $$out | grep 'mysqld is alive' || { echo $$out; exit 1; }
interval: 1m
timeout: 10s
retries: 5
```
## Redis
```yaml
healthcheck:
test: [ 'CMD', 'redis-cli', 'ping' ]
interval: 5m
timeout: 10s
retries: 5
```
## PostgreSQL
pg_isready не очень полезно, потому что часто служба может работать, но БД недоступна.
```yaml
healthcheck:
test: [ "CMD", "psql", "-U", "postgres", "-c", "SELECT 1;" ]
interval: 1m
timeout: 10s
retries: 5
```
## Curl
Ensure you use --fail or your health check will always succeed.
```yaml
healthcheck:
test: [ "CMD", "curl", "--fail", "http://localhost" ]
interval: "60s"
timeout: "5s"
retries: 3
```

Binary file not shown.

After

Width:  |  Height:  |  Size: 2.3 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 3.3 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 3.2 KiB

@ -0,0 +1,15 @@
## Отключение обновления экрана
```vba
Application.ScreenUpdating = False
' в конце
Application.ScreenUpdating = True
```
## Список уникальных значений VBA
```vba
PS = Range("A" & Rows.Count).End(xlUp).Row
Range("N6:N" & PS).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("T11"), Unique:=True
Range("T11:T300").Font.ColorIndex = 5
MsgBox "Создали уникальный список источников"
```

@ -0,0 +1,15 @@
# Исправление примечаний VBA
Бывает так, что ты вставляешь примечания и они уползают вниз при действиях со строками. 
Чтобы такого не было, используй этот макрос:
```vba
Sub align_comments()
Dim x As Comment
For Each x In ActiveSheet.Comments
x.Shape.Left = x.Parent.Offset(0, 1).Left + 10
x.Shape.Top = x.Parent.Top
Next
End Sub
```

@ -0,0 +1,12 @@
# Создание файла VBA
Простое
```vba
iFullName = ThisWorkbook.Path & "name.xlsx"
```
С именем из ячейки:
```vba
iFullName = ThisWorkbook.Path & "\" & Range("A1").Value & ".xlsx"
```

@ -0,0 +1,39 @@
# Открытие файла VBA
## 1 файл
Для открытия 1 файла и передачи его на дальнейшую обработку, используй этот код:
```vba
avFiles = Application.GetOpenFilename _
("Excel files(*.xls*),*.xls*", 1, "Выбери Excel файл", , False)
If VarType(avFiles) = vbBoolean Then
'была нажата кнопка отмены - выход из процедуры
Exit Sub
End If
Set avFiles1 = Workbooks.Open(Filename:=avFiles)
```
## Несколько файлов
Чтобы открыть много файлов и запустить обработку по ним, используем цикл:
```vba
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="All files (*.*), *.*", _
MultiSelect:=True, Title:="Files to Merge")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "Не выбрано ни одного файла!"
Exit Sub
End If
'проходим по всем выбранным файлам
x = 1
While x <= UBound(FilesToOpen)
With Workbooks.Open(FilesToOpen(x)).Sheets(1)
...
...
End With
x = x + 1
Wend
```

@ -0,0 +1,83 @@
# Прогресс бар VBA
> Использование APPLICATION.STATUSBAR
## Прогресс бар внизу страницы:
```vba
Application.StatusBar = "TEST"
DoEvents
...
Application.StatusBar = False
```
## Прогресс бар для циклов:
```vba
For i = 1 To n
Istochnik = Cells(i, 20)
Application.StatusBar = "Делаю источник " & i & "-" & Istochnik & "/" & 50 & ""
DoEvents
Next
```
## Можно сделать показ % завершения:
![](../../../images/other/office/excel-vba-progress-bar-01.png)
```vba
Sub ShowProgressBar()
Dim lAllCnt As Long, lr as Long
Dim rc As Range
'кол-во ячеек в выделенной области
lAllCnt = Selection.Count
'цикл по всем ячейкам в выделенной области
For Each rc In Selection
'прибавляем 1 при каждом шаге
lr = lr + 1
Application.StatusBar = "Выполнено: " & Int(100 * lr / lAllCnt) & "%"
DoEvents 'чтобы форма перерисовывалась
Next
'сбрасываем значение статусной строки
Application.StatusBar = False
End Sub
```
## Текст + блоки символов из 10 штук:
![](../../../images/other/office/excel-vba-progress-bar-02.png)
```vba
Sub StatusBar2()
Dim lr As Long, lp As Double
Dim lAllCnt As Long 'кол-во итераций
Dim s As String
lAllCnt = 10000
For lr = 1 To lAllCnt
lp = lr \ 100 'десятая часть всего массива
'формируем строку символов(от 1 до 10)
s = String(lp \ 10, ChrW(10152)) & String(11 - lp \ 10, ChrW(8700))
Application.StatusBar = "Выполнено: " & lp & "% " & s: DoEvents
DoEvents
Next
'очищаем статус-бар от значений после выполнения
Application.StatusBar = False
End Sub
```
## Текст + блоки квадратов из n штук:
количество квадратов можно менять
![](../../../images/other/office/excel-vba-progress-bar-03.png)
```vba
Sub StatusBar3()
Dim lr As Long
Dim lAllCnt As Long 'кол-во итераций
Const lMaxQuad As Long = 20 'сколько квадратов выводить
lAllCnt = 10000
For lr = 1 To lAllCnt
Application.StatusBar = "Выполнено: " & Int(100 * lr / lAllCnt) & "%" & String(CLng(lMaxQuad * lr / lAllCnt), ChrW(9632)) & String(lMaxQuad - CLng(lMaxQuad * lr / lAllCnt), ChrW(9633))
DoEvents
Next
'очищаем статус-бар от значений после выполнения
Application.StatusBar = False
End Sub
```

@ -0,0 +1,186 @@
# Удаление пароля VBA
> Пожалуйста, сделайте резервную копию ваших файлов в первую очередь!
{.is-warning}
## Для 32 битной версии
Откройте файл(ы), которые содержат ваши заблокированные проекты VBA
Создайте новый файл **xlsm** и сохраните этот код в `Module1`
```vba
code credited to Siwtom (nick name), a Vietnamese developer
Option Explicit
Private Const PAGE_EXECUTE_READWRITE = &H40
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Long, Source As Long, ByVal Length As Long)
Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, _
ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, _
ByVal pTemplateName As Long, ByVal hWndParent As Long, _
ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
Dim HookBytes(0 To 5) As Byte
Dim OriginBytes(0 To 5) As Byte
Dim pFunc As Long
Dim Flag As Boolean
Private Function GetPtr(ByVal Value As Long) As Long
GetPtr = Value
End Function
Public Sub RecoverBytes()
If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6
End Sub
Public Function Hook() As Boolean
Dim TmpBytes(0 To 5) As Byte
Dim p As Long
Dim OriginProtect As Long
Hook = False
pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")
If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then
MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6
If TmpBytes(0) <> &H68 Then
MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6
p = GetPtr(AddressOf MyDialogBoxParam)
HookBytes(0) = &H68
MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4
HookBytes(5) = &HC3
MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6
Flag = True
Hook = True
End If
End If
End Function
Private Function MyDialogBoxParam(ByVal hInstance As Long, _
ByVal pTemplateName As Long, ByVal hWndParent As Long, _
ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
If pTemplateName = 4070 Then
MyDialogBoxParam = 1
Else
RecoverBytes
MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _
hWndParent, lpDialogFunc, dwInitParam)
Hook
End If
End Function
```
Вставьте этот код под вышеуказанным кодом в Module1 и запустите его
```vba
Sub unprotected()
If Hook Then
MsgBox "VBA Project is unprotected!", vbInformation, "*****"
End If
End Sub
```
Возвращайтесь к своим проектам VBA и наслаждайтесь.
## Для 64 битной версии:
Откройте файл (ы), содержащий ваши заблокированные проекты VBA.
Создайте новый файл xlsm и сохраните этот код в `Module1`
```vba
Option Explicit
Private Const PAGE_EXECUTE_READWRITE = &H40
Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As LongPtr, Source As LongPtr, ByVal Length As LongPtr)
Private Declare PtrSafe Function VirtualProtect Lib "kernel32" (lpAddress As LongPtr, _
ByVal dwSize As LongPtr, ByVal flNewProtect As LongPtr, lpflOldProtect As LongPtr) As LongPtr
Private Declare PtrSafe Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, _
ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As LongPtr, _
ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _
ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
Dim HookBytes(0 To 5) As Byte
Dim OriginBytes(0 To 5) As Byte
Dim pFunc As LongPtr
Dim Flag As Boolean
Private Function GetPtr(ByVal Value As LongPtr) As LongPtr
GetPtr = Value
End Function
Public Sub RecoverBytes()
If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6
End Sub
Public Function Hook() As Boolean
Dim TmpBytes(0 To 5) As Byte
Dim p As LongPtr
Dim OriginProtect As LongPtr
Hook = False
pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")
If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then
MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6
If TmpBytes(0) <> &H68 Then
MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6
p = GetPtr(AddressOf MyDialogBoxParam)
HookBytes(0) = &H68
MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4
HookBytes(5) = &HC3
MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6
Flag = True
Hook = True
End If
End If
End Function
Private Function MyDialogBoxParam(ByVal hInstance As LongPtr, _
ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _
ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
If pTemplateName = 4070 Then
MyDialogBoxParam = 1
Else
RecoverBytes
MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _
hWndParent, lpDialogFunc, dwInitParam)
Hook
End If
End Function
```
Вставьте этот код в Module2 и запустите его
```vba
Sub unprotected()
If Hook Then
MsgBox "VBA Project is unprotected!", vbInformation, "*****"
End If
End Sub
```

@ -0,0 +1,34 @@
# Защита страницы через VBA
Каждый кто хоть раз писал макросы, сталкивался с тем, что требуется защитить лист и формулы на нем от шаловливых ручек пользователей. При том, нужно чтобы макросы на листе работали. Самое просто решение, это перед кодом макроса, добавить это:
```vba
Worksheets("Лист1").Unprotect Password:="123"
'тут макрос делает действия
Worksheets("Лист1").Protect Password:="123"
```
Это будет работать, но у такого подхода есть и свои минусы. Во-первых, нужно эту конструкцию размещать в каждом макросе. Во-вторых - если будет ошибка, лист останется без защиты.
## Есть другой способ
Нажмите `Alt+F11`, чтобы попасть в редактор Visual Basic. Затем в левом верхнем углу в окне Project Explorer (если его не видно, то нажмите Ctrl+R) модуль ЭтаКнига (ThisWorkbook) и откройте двойным щелчком:
![]( ../../images/other/office/excel_vba_01.png){ loading=lazy }
Вставьте этот код:
```vba
Private Sub Workbook_Open()
'включаем защиту первого листа для пользователя, но не макроса
Worksheets("Лист1").Protect Password:="123", UserInterfaceOnly:=True
'второй лист защищаем аналогично, но с возможностью пользоваться группировкой
Worksheets("Лист2").EnableOutlining = True
Worksheets("Лист2").Protect Password:="555", UserInterfaceOnly:=True
End Sub
```
Данный код будет автоматически запускаться при открытии файла и ставить защиту на заданные листы. Параметр `UserInterfaceOnly` указывает Excel, что защита не должна работать для действий макроса, а только на операции юзера.
Второй параметр `EnableOutlining` разрешает пользоваться группировкой.

@ -0,0 +1,32 @@
# Отправка почты VBA
отправляет почту, используя для этого запущенный MS Outlook
```vba
' Запрос ввода темы письма
Dim vRetVal
vRetVal = InputBox("Введи тему письма", "Тема", "Test")
ActiveSheet.Range("I3").Value = vRetVal
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Send_ist = Cells(1, 1)
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Send_ist
.Body = "Заполнить в день получения и отправить обратно на your_email"
.Subject = Range("A1").Value
.Attachments.Add iFullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
```

@ -1,422 +0,0 @@
## Защита страницы через VBA
Каждый кто хоть раз писал макросы, сталкивался с тем, что требуется защитить лист и формулы на нем от шаловливых ручек пользователей. При том, нужно чтобы макросы на листе работали. Самое просто решение, это перед кодом макроса, добавить это:
```vba
Worksheets("Лист1").Unprotect Password:="123"
'тут макрос делает действия
Worksheets("Лист1").Protect Password:="123"
```
Это будет работать, но у такого подхода есть и свои минусы. Во-первых, нужно эту конструкцию размещать в каждом макросе. Во-вторых - если будет ошибка, лист останется без защиты.
### Есть другой способ
Нажмите `Alt+F11`, чтобы попасть в редактор Visual Basic. Затем в левом верхнем углу в окне Project Explorer (если его не видно, то нажмите Ctrl+R) модуль ЭтаКнига (ThisWorkbook) и откройте двойным щелчком:
![]( ../../images/other/office/excel_vba_01.png){ loading=lazy }
Вставьте этот код:
```vba
Private Sub Workbook_Open()
'включаем защиту первого листа для пользователя, но не макроса
Worksheets("Лист1").Protect Password:="123", UserInterfaceOnly:=True
'второй лист защищаем аналогично, но с возможностью пользоваться группировкой
Worksheets("Лист2").EnableOutlining = True
Worksheets("Лист2").Protect Password:="555", UserInterfaceOnly:=True
End Sub
```
Данный код будет автоматически запускаться при открытии файла и ставить защиту на заданные листы. Параметр `UserInterfaceOnly` указывает Excel, что защита не должна работать для действий макроса, а только на операции юзера.
Второй параметр `EnableOutlining` разрешает пользоваться группировкой.
## Исправление примечаний VBA
Бывает так, что ты вставляешь примечания и они уползают вниз при действиях со строками. 
Чтобы такого не было, используй этот макрос:
```vba
Sub align_comments()
Dim x As Comment
For Each x In ActiveSheet.Comments
x.Shape.Left = x.Parent.Offset(0, 1).Left + 10
x.Shape.Top = x.Parent.Top
Next
End Sub
```
## Открытие файла VBA
Для открытия 1 файла и передачи его на дальнейшую обработку, используй этот код:
```vba
avFiles = Application.GetOpenFilename _
("Excel files(*.xls*),*.xls*", 1, "Выбери Excel файл", , False)
If VarType(avFiles) = vbBoolean Then
'была нажата кнопка отмены - выход из процедуры
Exit Sub
End If
Set avFiles1 = Workbooks.Open(Filename:=avFiles)
```
Чтобы открыть много файлов и запустить обработку по ним, используем цикл:
```vba
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="All files (*.*), *.*", _
MultiSelect:=True, Title:="Files to Merge")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "Не выбрано ни одного файла!"
Exit Sub
End If
'проходим по всем выбранным файлам
x = 1
While x <= UBound(FilesToOpen)
With Workbooks.Open(FilesToOpen(x)).Sheets(1)
...
...
End With
x = x + 1
Wend
```
## Отправка почты VBA
отправляет почту, используя для этого запущенный MS Outlook
```vba
' Запрос ввода темы письма
Dim vRetVal
vRetVal = InputBox("Введи тему письма", "Тема", "Test")
ActiveSheet.Range("I3").Value = vRetVal
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Send_ist = Cells(1, 1)
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Send_ist
.Body = "Заполнить в день получения и отправить обратно на your_email"
.Subject = Range("A1").Value
.Attachments.Add iFullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
```
## Отключение обновления экрана
```vba
Application.ScreenUpdating = False
' в конце
Application.ScreenUpdating = True
```
## Прогресс бар VBA
> Использование APPLICATION.STATUSBAR
{.is-info}
### Прогресс бар внизу страницы:
```vba
Application.StatusBar = "TEST"
DoEvents
...
Application.StatusBar = False
```
### Прогресс бар для циклов:
```vba
For i = 1 To n
Istochnik = Cells(i, 20)
Application.StatusBar = "Делаю источник " & i & "-" & Istochnik & "/" & 50 & ""
DoEvents
Next
```
### Можно сделать показ % завершения:
![](https://pics.thest1tch.ru/pic/xwbza0bv.png)
```vba
Sub ShowProgressBar()
Dim lAllCnt As Long, lr as Long
Dim rc As Range
'кол-во ячеек в выделенной области
lAllCnt = Selection.Count
'цикл по всем ячейкам в выделенной области
For Each rc In Selection
'прибавляем 1 при каждом шаге
lr = lr + 1
Application.StatusBar = "Выполнено: " & Int(100 * lr / lAllCnt) & "%"
DoEvents 'чтобы форма перерисовывалась
Next
'сбрасываем значение статусной строки
Application.StatusBar = False
End Sub
```
### Текст + блоки символов из 10 штук:
![](https://pics.thest1tch.ru/pic/umeq366g.png)
```vba
Sub StatusBar2()
Dim lr As Long, lp As Double
Dim lAllCnt As Long 'кол-во итераций
Dim s As String
lAllCnt = 10000
For lr = 1 To lAllCnt
lp = lr \ 100 'десятая часть всего массива
'формируем строку символов(от 1 до 10)
s = String(lp \ 10, ChrW(10152)) & String(11 - lp \ 10, ChrW(8700))
Application.StatusBar = "Выполнено: " & lp & "% " & s: DoEvents
DoEvents
Next
'очищаем статус-бар от значений после выполнения
Application.StatusBar = False
End Sub
```
### Текст + блоки квадратов из n штук:
количество квадратов можно менять
![](https://pics.thest1tch.ru/pic/pq1o9ua4.png)
```vba
Sub StatusBar3()
Dim lr As Long
Dim lAllCnt As Long 'кол-во итераций
Const lMaxQuad As Long = 20 'сколько квадратов выводить
lAllCnt = 10000
For lr = 1 To lAllCnt
Application.StatusBar = "Выполнено: " & Int(100 * lr / lAllCnt) & "%" & String(CLng(lMaxQuad * lr / lAllCnt), ChrW(9632)) & String(lMaxQuad - CLng(lMaxQuad * lr / lAllCnt), ChrW(9633))
DoEvents
Next
'очищаем статус-бар от значений после выполнения
Application.StatusBar = False
End Sub
```
## Создание файла VBA
Простое
```vba
iFullName = ThisWorkbook.Path & "name.xlsx"
```
С именем из ячейки:
```vba
iFullName = ThisWorkbook.Path & "\" & Range("A1").Value & ".xlsx"
```
## Список уникальных значений VBA
```vba
PS = Range("A" & Rows.Count).End(xlUp).Row
Range("N6:N" & PS).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("T11"), Unique:=True
Range("T11:T300").Font.ColorIndex = 5
MsgBox "Создали уникальный список источников"
```
## Удаление пароля VBA
> Пожалуйста, сделайте резервную копию ваших файлов в первую очередь!
{.is-warning}
### Для 32 битной версии
Откройте файл(ы), которые содержат ваши заблокированные проекты VBA
Создайте новый файл **xlsm** и сохраните этот код в `Module1`
```vba
code credited to Siwtom (nick name), a Vietnamese developer
Option Explicit
Private Const PAGE_EXECUTE_READWRITE = &H40
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Long, Source As Long, ByVal Length As Long)
Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, _
ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, _
ByVal pTemplateName As Long, ByVal hWndParent As Long, _
ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
Dim HookBytes(0 To 5) As Byte
Dim OriginBytes(0 To 5) As Byte
Dim pFunc As Long
Dim Flag As Boolean
Private Function GetPtr(ByVal Value As Long) As Long
GetPtr = Value
End Function
Public Sub RecoverBytes()
If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6
End Sub
Public Function Hook() As Boolean
Dim TmpBytes(0 To 5) As Byte
Dim p As Long
Dim OriginProtect As Long
Hook = False
pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")
If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then
MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6
If TmpBytes(0) <> &H68 Then
MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6
p = GetPtr(AddressOf MyDialogBoxParam)
HookBytes(0) = &H68
MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4
HookBytes(5) = &HC3
MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6
Flag = True
Hook = True
End If
End If
End Function
Private Function MyDialogBoxParam(ByVal hInstance As Long, _
ByVal pTemplateName As Long, ByVal hWndParent As Long, _
ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
If pTemplateName = 4070 Then
MyDialogBoxParam = 1
Else
RecoverBytes
MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _
hWndParent, lpDialogFunc, dwInitParam)
Hook
End If
End Function
```
Вставьте этот код под вышеуказанным кодом в Module1 и запустите его
```vba
Sub unprotected()
If Hook Then
MsgBox "VBA Project is unprotected!", vbInformation, "*****"
End If
End Sub
```
Возвращайтесь к своим проектам VBA и наслаждайтесь.
### Для 64 битной версии:
Откройте файл (ы), содержащий ваши заблокированные проекты VBA.
Создайте новый файл xlsm и сохраните этот код в `Module1`
```vba
Option Explicit
Private Const PAGE_EXECUTE_READWRITE = &H40
Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As LongPtr, Source As LongPtr, ByVal Length As LongPtr)
Private Declare PtrSafe Function VirtualProtect Lib "kernel32" (lpAddress As LongPtr, _
ByVal dwSize As LongPtr, ByVal flNewProtect As LongPtr, lpflOldProtect As LongPtr) As LongPtr
Private Declare PtrSafe Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, _
ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As LongPtr, _
ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _
ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
Dim HookBytes(0 To 5) As Byte
Dim OriginBytes(0 To 5) As Byte
Dim pFunc As LongPtr
Dim Flag As Boolean
Private Function GetPtr(ByVal Value As LongPtr) As LongPtr
GetPtr = Value
End Function
Public Sub RecoverBytes()
If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6
End Sub
Public Function Hook() As Boolean
Dim TmpBytes(0 To 5) As Byte
Dim p As LongPtr
Dim OriginProtect As LongPtr
Hook = False
pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")
If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then
MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6
If TmpBytes(0) <> &H68 Then
MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6
p = GetPtr(AddressOf MyDialogBoxParam)
HookBytes(0) = &H68
MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4
HookBytes(5) = &HC3
MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6
Flag = True
Hook = True
End If
End If
End Function
Private Function MyDialogBoxParam(ByVal hInstance As LongPtr, _
ByVal pTemplateName As LongPtr, ByVal hWndParent As LongPtr, _
ByVal lpDialogFunc As LongPtr, ByVal dwInitParam As LongPtr) As Integer
If pTemplateName = 4070 Then
MyDialogBoxParam = 1
Else
RecoverBytes
MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _
hWndParent, lpDialogFunc, dwInitParam)
Hook
End If
End Function
```
Вставьте этот код в Module2 и запустите его
```vba
Sub unprotected()
If Hook Then
MsgBox "VBA Project is unprotected!", vbInformation, "*****"
End If
End Sub
```

@ -48,6 +48,16 @@ nav:
- Установка TelnetCE: other/tsd/install-telnetce.md
- Synology:
- HPE Microserver Gen10: other/synology/install-hpe-ms-gen10
- Office:
- Excel:
- other/office/excel/index.md
- VBA Защита страницы: other/office/excel/vba-security-page.md
- VBA Исправление примечаний: other/office/excel/vba-align-comments.md
- VBA Создание файла: other/office/excel/vba-create-file.md
- VBA Открытие файла: other/office/excel/vba-open-file.md
- VBA Отправка почты: other/office/excel/vba-send-email.md
- VBA Прогресс бар: other/office/excel/vba-progress-bar.md
- VBA Удаление пароля: other/office/excel/vba-remove-pass.md
- Сеть:
- Mikrotik:

Loading…
Cancel
Save