1 (изменено: Xameleon, 2011-03-11 13:07:33)

Тема: VBA: Обход ограничений на запуск макросов

И снова здраствуйте. ) Сегодня ковырялся с VBA кодом. На сайте фоурма в разделе управления офисом нашёл код вызова API функции Beep
Windows Scripting: MS Office

'Создание объекта Word:
'Set objOffice = CreateObject("Word.Application")
'objOffice.Documents.Add
'Примечание: если в момент запуска этого скрипта Word уже запущен, в момент удаления временного
'модуля VBA произойдёт конфликт доступа к Normal.dot.

'Создание объекта Excel:
Set objOffice = CreateObject("Excel.Application")
objOffice.DisplayAlerts = False
Set objWorkBook = objOffice.WorkBooks.Add
objWorkBook.Worksheets.Add

i = objOffice.VBE.ActiveVBProject.VBComponents.Count
objOffice.VBE.ActiveVBProject.VBComponents.Add 1
Set objModule = objOffice.VBE.ActiveVBProject.VBComponents.Item(i + 1)
With objModule.CodeModule
    .InsertLines 1,  "Public Declare Function Beep Lib ""kernel32"" _"
    .InsertLines 2,  "(ByVal dwFreq As Long, ByVal dwDuration As Long) As Long"
    .InsertLines 3,  "Sub TestSub(Caption as String, Text as String)"
    .InsertLines 4,  "    MsgBox Text, vbOkOnly + vbInformation, Caption"
    .InsertLines 5,  "End Sub"
    .InsertLines 6,  "Sub TestBeep()"
    .InsertLines 7,  "    res = Beep(500, 100)"
    .InsertLines 8,  "    res = Beep(550, 100)"
    .InsertLines 9,  "    res = Beep(600, 100)"
    .InsertLines 10, "    res = Beep(650, 100)"
    .InsertLines 11, "    res = Beep(700, 100)"
    .InsertLines 12, "    res = Beep(650, 100)"
    .InsertLines 13, "    res = Beep(600, 100)"
    .InsertLines 14, "    res = Beep(550, 100)"
    .InsertLines 15, "    res = Beep(500, 700)"
    .InsertLines 16, "End Sub"
End With
objOffice.Application.Run "TestSub", "Test VBA", "Сейчаc будет произведён вызов Win32 API функции Beep()..."
objOffice.Application.Run "TestBeep"
'Следующая строка нужна, если используется Word:
'objOffice.VBE.ActiveVBProject.VBComponents.Remove objModule
objOffice.Quit

Запустив у себя, получил сообщение о том что "Программный доступ к проекту Visual Basic не является доверенным."
Эта несправедливость меня несколько огорчила. Порыв в инете, наткнулся на то, что эта проблема решается ручным переключением безопасности в настройках офиса либо добавлением данных в реестр. Ну совсем расстроило. Решил обойти эту проблему.

Set Document = CreateObject("Word.Document")
Set VBComponent = Document.VBProject.VBComponents.Add(1)
With VBComponent.CodeModule
    .InsertLines 1,  "Public Declare Function Beep Lib ""kernel32"" _"
    .InsertLines 2,  "(ByVal dwFreq As Long, ByVal dwDuration As Long) As Long"
    .InsertLines 3,  "Sub TestSub(Caption as String, Text as String)"
    .InsertLines 4,  "    MsgBox Text, vbOkOnly + vbInformation, Caption"
    .InsertLines 5,  "End Sub"
    .InsertLines 6,  "Sub TestBeep()"
    .InsertLines 7,  "    res = Beep(400, 400)"
    .InsertLines 16, "End Sub"
End With
Document.Application.Run "TestBeep"

Вот что получилось. Хотелось узнать - действительно это работает или я свой комп уже так замучал, что он на всё согласен ?

Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

2 (изменено: VSVLAD, 2011-03-11 13:20:11)

Re: VBA: Обход ограничений на запуск макросов

Проверил в Office 2003. Работает в том случае, если разрешён доступ к VB Project. Если убрать разрешение - не работает.

3 (изменено: Xameleon, 2011-03-11 14:22:28)

Re: VBA: Обход ограничений на запуск макросов

Ясно. Благодарю.

--

Значит наверное всё таки решу вопрос, добавлением и удалением ключиков в реестре.

Передумал переделывать мир. Пашет и так, ну и ладно. Сделаю лучше свой !

4

Re: VBA: Обход ограничений на запуск макросов

Нашел статейку о разрешении выполнении макросов Excel.

Вот одно из решений проблемы:

REGEDIT4

[HKEY_LOCAL_MACHINE\Software\Microsoft\Office\9.0\Excel\Security]
"XLM"=dword:00000001
[HKEY_LOCAL_MACHINE\Software\Microsoft\Office\10.0\Excel\Security]
"XLM"=dword:00000001
[HKEY_LOCAL_MACHINE\Software\Microsoft\Office\11.0\Excel\Security]
"XLM"=dword:00000001