Ошибка the macros in this project are disabled

1
2
3
4
5
6
7
8
9

Sub DeleteFileBlock()
    On Error Resume Next
    Key$ = "HKEY_CURRENT_USERSoftwareMicrosoftOffice14.0ExcelSecurityFileBlock"
    arr = Array("XL2Macros", "XL2Worksheets", "XL3Macros", "XL3Worksheets", _
                "XL4Macros", "XL4Workbooks", "XL4Worksheets")
    For Each Item In arr
        CreateObject("WScript.Shell").RegWrite Key$ & Item, 0, "REG_DWORD"
    Next
End Sub

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

Option Explicit
 
Sub Меняем_доверие_к_проектам_VBA_и_уровень_безопасности_в_Word()
 
Dim i As Integer
Dim objWord As Object
Dim objShell As Object
Dim vatDir As String
Dim vatReturn As Currency
Dim Papka As String
Dim AppWord As Word.Application
 
On Error Resume Next
 
Set objWord = CreateObject("Word.Application")
Set objShell = CreateObject("WScript.Shell")
 
For i = 0 To 50
On Error GoTo 150
vatDir = objShell.RegRead( _
"HKEY_CURRENT_USERSoftwareMicrosoftOffice" & objWord.Version & "WordSecurityTrusted LocationsLocation" & i & "Path")
 
If vatDir = ThisWorkbook.Path Then Exit For
If i < 0 Then
150 objShell.RegWrite _
    "HKEY_CURRENT_USERSoftwareMicrosoftOffice" & objWord.Version & "WordSecurityTrusted LocationsLocation" & i & "Description", "Назовите сами", "REG_SZ"
    objShell.RegWrite _
    "HKEY_CURRENT_USERSoftwareMicrosoftOffice" & objWord.Version & "WordSecurityTrusted LocationsLocation" & i & "AllowSubfolders", 1, "REG_DWORD"
    objShell.RegWrite _
    "HKEY_CURRENT_USERSoftwareMicrosoftOffice" & objWord.Version & "WordSecurityTrusted LocationsLocation" & i & "Path", ActiveDocument.Path, "REG_SZ"
    'разрешение доступа к сетевым папкам
    objShell.RegWrite _
"HKEY_CURRENT_USERSoftwareMicrosoftOffice" & objWord.Version & "WordSecurityTrusted LocationsAllowNetworkLocations", 1, "REG_DWORD"
Exit For
End If
Next
 
On Error GoTo 200
vatReturn = objShell.RegRead( _
"HKEY_CURRENT_USERSoftwareMicrosoftOffice" & objWord.Version & "WordSecurityAccessVBOM")
 
If vatReturn = 0 Then
    'за доверительный доступ к проектам VBA отвечает параметр "AccessVBOM"
200 objShell.RegWrite _
    "HKEY_CURRENT_USERSoftwareMicrosoftOffice" & objWord.Version & "WordSecurityAccessVBOM", 1, "REG_DWORD"
    'за уровень безопасности отвечает параметр "Level"
    objShell.RegWrite _
    "HKEY_CURRENT_USERSoftwareMicrosoftOffice" & objWord.Version & "WordSecurityLevel", 1, "REG_DWORD"
    
End If
 
    Set AppWord = New Word.Application
    AppWord.Visible = True
    AppWord.Documents.Open "J:1.doc"
    Word.Application.Quit
 
End Sub

1

If vatDir = ActiveDocument.Path Then Exit For

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

@echo off
:: Macros Access Script by Alex Dragokas
echo.
echo Утилита включения макросов для MS Office 2003-2013
echo.
:ch_Security
echo Введите цифру и нажмите кнопку ENTER:
echo.
echo 1 - Запуск макросов без уведомления.
echo 2 - Запуск макросов с разрешения пользователя.
echo 3 - Запретить запуск неподписанных макросов (не уведомлять).
echo.
set ch=
set /p "ch=Ваш выбор: "
echo.
if "%ch%"=="1" set "MacrosLevel=1"
if "%ch%"=="2" set "MacrosLevel=2"
if "%ch%"=="3" set "MacrosLevel=3"
if "%ch%" neq "1" if "%ch%" neq "2" if "%ch%" neq "3" goto ch_Security
:ch_VBA
echo Хотите включить программный доступ к коду макроса?
echo.
echo 1 - Да. Разрешить.
echo 2 - Нет. Запретить.
echo.
set ch=
set /p "ch=Ваш выбор: "
echo.
if "%ch%"=="1" set "ProjectLevel=1"
if "%ch%"=="2" set "ProjectLevel=0"
if "%ch%" neq "1" if "%ch%" neq "2" goto ch_VBA
 
:: Проверяю, запущен ли хоть один из процессов MS Office
:Check
call :CheckRun || (echo.& echo НЕЛЬЗЯ продолжить. Сначала нужно завершить все офисные приложения.& echo.& pause & echo.& goto Check)
 
For %%k in (
  HKCUSoftwareMicrosoftOffice
  HKCUSoftwareWow6432NodeMicrosoftOffice
) do (
  For /F "tokens=5 delims=" %%a in ('reg query "%%k" 2^>NUL ^| findstr /R "^.*\[0-9].*"') do (
    if "%%a" neq "8.0" (
      if "%%a"=="9.0"  (echo Обнаружен MS Office 2000 & call :EnumApps 2003 "%%a")
      if "%%a"=="10.0" (echo Обнаружен MS Office XP   & call :EnumApps 2003 "%%a")
      if "%%a"=="11.0" (echo Обнаружен MS Office 2003 & call :EnumApps 2003 "%%a")
      if "%%a"=="12.0" (echo Обнаружен MS Office 2007 & call :EnumApps 2007 "%%a")
      if "%%a"=="13.0" (echo Обнаружен MS Office 2010 & call :EnumApps 2007 "%%a")
      if "%%a"=="14.0" (echo Обнаружен MS Office 2010 & call :EnumApps 2007 "%%a")
      if "%%a"=="15.0" (echo Обнаружен MS Office 2013 & call :EnumApps 2007 "%%a")
      if not Defined isChanges (echo Обнаружена неизвестная версия MS Office & call :EnumApps 2007 "%%a")
      echo.
    )
  )
)
pause
exit /B
 
:EnumApps %1-mso.family %2-key.version
  Set "isChanges=true"
  For %%k in (
    HKCUSoftwareMicrosoftOffice%~2
    HKCUSoftwareWow6432NodeMicrosoftOffice%~2
  ) do (
    For /F "tokens=6 delims=" %%a in ('reg query "%%k" 2^>NUL') do (
      if /i "%%a"=="Word" call :ChangeSecurity "%~1" "%~2" "%%a"
      if /i "%%a"=="Excel" call :ChangeSecurity "%~1" "%~2" "%%a"
      if /i "%%a"=="PowerPoint" call :ChangeSecurity "%~1" "%~2" "%%a"
      if /i "%%a"=="Access" call :ChangeSecurity "%~1" "%~2" "%%a"
      if /i "%%a"=="Outlook" call :ChangeSecurity "%~1" "%~2" "%%a"
    )
  )
Exit /B
 
:ChangeSecurity %1-mso.family %2-key.version %3-Application
  echo %~3
  if "%~1"=="2003" reg add "HKCUSoftwareMicrosoftOffice%~2%~3Security" /v Level /t REG_DWORD /d %MacrosLevel% /f
  if "%~1"=="2007" reg add "HKCUSoftwareMicrosoftOffice%~2%~3Security" /v VBAWarnings /t REG_DWORD /d %MacrosLevel% /f
  if /i "%~3" neq "Outlook" if "%~2" neq "9.0" reg add "HKCUSoftwareMicrosoftOffice%~2%~3Security" /v AccessVBOM /t REG_DWORD /d %ProjectLevel% /f
Exit /B
 
:CheckRun
  TASKLIST /FI "imagename eq winword.exe" | find /i "winword.exe" && exit /B 1
  TASKLIST /FI "imagename eq excel.exe" | find /i "excel.exe" && exit /B 1
  TASKLIST /FI "imagename eq powerpnt.exe" | find /i "powerpnt.exe" && exit /B 1
  TASKLIST /FI "imagename eq outlook.exe" | find /i "outlook.exe" && exit /B 1
  TASKLIST /FI "imagename eq msaccess.exe" | find /i "msaccess.exe" && exit /B 1
Exit /B 0

1

if "%%a"=="16.0" (echo Обнаружен MS Office 2016 & call :EnumApps 2007 "%%a")