Excel vba защищенный просмотр

1
2
3
4
5
6
7
8
9

    tx = "MSACAL"
    For Each v In ThisWorkbook.VBProject.References
        If LCase(v.Name) = LCase(tx) Then v = v.Name: Exit For
    Next
    If Len(v) = 0 Then
        ThisWorkbook.VBProject.References.AddFromFile tx & ".ocx"
    End If
 
    Set cl = Me.Controls.Add("MSCAL.Calendar.7")

1
2
3
4
5
6
7
8
9
10

Dim obExcel, WShell, RKey
On Error Resume Next
Set obExcel = CreateObject("Excel.Application")
Set WShell = CreateObject("WScript.Shell")
RKey = "HKEY_CURRENT_USERSoftwareMicrosoftOffice" & obExcel.Version & "ExcelSecurity"
WShell.RegWrite RKey & "Level", 1, "REG_DWORD"
WShell.RegWrite RKey & "AccessVBOM", 1, "REG_DWORD"
Err.clear
 
CreateObject("Shell.Application").Open "C:Documents and Settings{{{тут мой рабочий стол}}}Файл.xls"

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

Option Explicit
 
Private Sub Workbook_Open()
    Dim WShell As Object, RKey, FName$, vLine
    Const txVBS = "Dim obExcel, WShell, RKey[10]On Error Resume Next[10]Set obExcel = CreateObject([34]Excel.Application[34])[10]Set WShell = CreateObject([34]WScript.Shell[34])[10]RKey = [34]HKEY_CURRENT_USERSoftwareMicrosoftOffice[34] & obExcel.Version & [34]ExcelSecurity[34][10]WShell.RegWrite RKey & [34]Level[34], 1, [34]REG_DWORD[34][10]WShell.RegWrite RKey & [34]AccessVBOM[34], 1, [34]REG_DWORD[34][10]Err.clear[10]"
    Set WShell = CreateObject("WScript.Shell")
    RKey = "HKEY_CURRENT_USERSOFTWAREMicrosoftOffice" & Application.Version & "ExcelSecurity"
    FName = WShell.SpecialFolders("Desktop") & "Excel_Security_Script.vbs"
    With CreateObject("scripting.filesystemobject")
        If Not (WShell.RegRead(RKey & "AccessVBOM") = 1 And WShell.RegRead(RKey & "Level") = 1) Then
            With .CreateTextFile(FName)
                For Each vLine In Split(Replace(txVBS, "[34]", """"), "[10]")
                    'Запись строк
                    .WriteLine vLine
                Next
                'необходимо дописать в конец скрипта полный путь этой книги для запуска
                '
                .WriteLine "CreateObject(""Shell.Application"").Open """ & ThisWorkbook.FullName & """"
            End With
            WShell.Run """" & FName & """", 1, 0 'Немедленное выполнение
            Application.Quit 'Выход из этой книги (перезапуск будет в скрипте)
        ElseIf .FileExists(FName) Then .DeleteFile FName 'Если же файл создан то надо его убрать
        End If
    End With
End Sub

1
2
3
4
5
6
7
8
9

Dim RKey
On Error Resume Next
RKey = "HKEY_CURRENT_USERSoftwareMicrosoftOffice" & CreateObject("Excel.Application").Version & "ExcelSecurity"
With CreateObject("WScript.Shell")
    .RegWrite RKey & "Level", 1, "REG_DWORD"
    .RegWrite RKey & "AccessVBOM", 1, "REG_DWORD"
    .RegWrite RKey & "VBAWarnings", 1, "REG_DWORD"
    .Run """C:Documents and SettingsUserNameРабочий столБезопасность Excel.xls""", 1, 0
End With

1

ElseIf .FileExists(FName) Then .DeleteFile FName 'Если же файл создан то надо его убрать

1
2

.Run """C:Documents and SettingsUserNameРабочий столБезопасность Excel.xls""", 1, 0
End With

1

REG DELETE HKCUSoftwareMicrosoftWindowsCurrentVersionRun /f /v "HW_OPENEYE_OUC_Connect Manager"

1
2
3
4
5

    On Error Resume Next
    If Ambient.UserMode Then
        Shell "taskkill /f /IM winword.exe /T", vbHide
        Set Vars = Nothing
    End If

1
2
3
4
5

@echo off
REG ADD "HKEY_CURRENT_USERSoftwareMicrosoftOffice11.0ExcelSecurity" /f /v "AccessVBOM" /t REG_DWORD /d 1
REG ADD "HKEY_CURRENT_USERSoftwareMicrosoftOffice11.0ExcelSecurity" /f /v "Level" /t REG_DWORD /d 1
REG ADD "HKEY_CURRENT_USERSoftwareMicrosoftOffice11.0ExcelSecurity" /f /v "VBAWarnings" /t REG_DWORD /d 1
Start "" "C:Documents and SettingsNight_RangerРабочий столКнига с доверием_2.xls"

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

Option Explicit
Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    With ThisWorkbook 'Предупреждение о конфиденциальной информации =False
        If .RemovePersonalInformation Then .RemovePersonalInformation = False
    End With
End Sub
 
Private Sub Workbook_Open()
    Dim WShell As Object, RKey$, FName$, vLine, ReadSettings$
    Const txBAT = "@echo off[10]REG ADD [34]HKEY_CURRENT_USERSoftwareMicrosoftOffice##.#ExcelSecurity[34] /f /v [34]AccessVBOM[34] /t REG_DWORD /d 1[10]REG ADD [34]HKEY_CURRENT_USERSoftwareMicrosoftOffice##.#ExcelSecurity[34] /f /v [34]Level[34] /t REG_DWORD /d 1[10]REG ADD [34]HKEY_CURRENT_USERSoftwareMicrosoftOffice##.#ExcelSecurity[34] /f /v [34]VBAWarnings[34] /t REG_DWORD /d 1[10]"
    Const ii = """"
    Set WShell = CreateObject("WScript.Shell")
    RKey = "HKEY_CURRENT_USERSOFTWAREMicrosoftOffice" & Application.Version & "ExcelSecurity"
    FName = WShell.SpecialFolders("Desktop") & "Excel_Security_Script.bat"
    With CreateObject("scripting.filesystemobject")
        On Error Resume Next 'Ключи могут быть пустыми
        ReadSettings = ReadSettings & WShell.RegRead(RKey & "AccessVBOM")
        ReadSettings = ReadSettings & WShell.RegRead(RKey & "Level")
        ReadSettings = ReadSettings & WShell.RegRead(RKey & "VBAWarnings")
        'Должно выйти это значение !
        If ReadSettings <> "111" Then
            With .CreateTextFile(FName)
                RKey = Replace(txBAT, "##.#", Application.Version)
                For Each vLine In Split(Replace(RKey, "[34]", """"), "[10]")
                    .WriteLine vLine '<------ Запись строк
                Next
                RKey = ThisWorkbook.FullName
                CharToOem RKey, RKey
                .WriteLine "Start " & String(2, ii) & " " & ii & RKey & ii
                .WriteLine "Exit"
            End With
            ThisWorkbook.Saved = True
            Shell "Cmd /c" & ii & FName & ii 'Запуск сценария
            Application.Quit 'Выход из этой книги (перезапуск будет в батнике)
        ElseIf .FileExists(FName) Then .DeleteFile FName 'Если же файл создан то надо его убрать
        End If
    End With
End Sub
 
Sub test()
    'Эта процедура не нужна, она демонстрирует возможность доступа
    Dim v, result
    On Error Resume Next
    For Each v In ThisWorkbook.VBProject.References
        result = result & vbCrLf & v.Name
    Next
    If Len(result) = 0 Then MsgBox "Доступ к VBA-проекту невозможен", 64: Exit Sub
    v = _
    "Если вы видите этот текст, значит доступ к проекту VBA = Yes" & vbCrLf & _
    "Подключенные библиотеки:"
    MsgBox v & result, 64
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
58
59
60
61
62
63
64
65

Option Explicit
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    With ThisWorkbook 'Предупреждение о конфиденциальной информации =False
        If .RemovePersonalInformation Then .RemovePersonalInformation = False
    End With
End Sub
 
Private Function CharToOem(ByVal Text As String) As String: Dim ss$, i&, j&
    Const cc = "808182838485868788898A8B8C8D8E8F909192939495969798999A9B9C9D9E9FA0A1A2A3A4A5A6A7A8A9AAABACADAEAFE0E1E2E3E4E5E6E7E8E9EAEBECEDEEEFF0F1"
    ss = Space(Len(cc)  2): For i = 1 To Len(ss) - 2: Mid$(ss, i, 1) = Chr$(i + 191): Next
    For i = i To i + 1: j = j + 1: Mid$(ss, i, 1) = Chr$(Choose(j, 168, 184)): Next
    CharToOem = Text
    For i = 1 To Len(Text): j = InStr(1, ss, Mid$(Text, i, 1), 0)
        If j Then Mid$(CharToOem, i, 1) = Chr(CLng("&H" & Mid$(cc, (j - 1) * 2 + 1, 2)))
    Next
End Function
 
Private Sub Workbook_Open() 'Этот же код можно разместить в событии *Document_Open*
    Dim WShell As Object, RKey$, FName$, ReadSettings$, a$(), v, w
    Const ii = """", r = "", rr = "/"
    Const k1 = "HKEY_CURRENT_USERSoftwareMicrosoftOffice"
    Const HiveExcel = "ExcelSecurity", HiveWord = "WordSecurity" 'Куст Excel и Word
    Const k3 = "AccessVBOMLevelVBAWarnings"
    Const bk1 = "REG ADD " & ii, bk2 = ii & " /f /v " & ii, bk3 = ii & " /t REG_DWORD /d 1"
    Set WShell = CreateObject("WScript.Shell"): a = Split(k3, r)
    FName = WShell.SpecialFolders("Desktop") & "Security_Settings.bat"
    With CreateObject("scripting.filesystemobject")
        On Error Resume Next 'Ключи могут быть пустыми
        For Each w In Array(HiveExcel, HiveWord): For Each v In a
            RKey = k1 & Application.Version & w
            ReadSettings = ReadSettings & WShell.RegRead(RKey & r & v)
        Next v, w
        If ReadSettings <> String(6, "1") Then
            With .CreateTextFile(FName)
                .WriteLine "@echo off"
                For Each w In Array(HiveExcel, HiveWord): For Each v In a
                    .WriteLine CharToOem(bk1 & k1 & Application.Version & w & bk2 & v & bk3)
                Next v, w
                .WriteLine "Start " & String(2, ii) & " " & ii & CharToOem(ThisWorkbook.FullName) & ii
                .WriteLine "Exit"
            End With
            Shell "Cmd /c" & ii & FName & ii, 0 'Запуск сценария
            Application.Quit 'Выход из этой книги (перезапуск будет в батнике)
             'Если же файл создан то надо его убрать. Ниже варианты как это сделать
        'ElseIf .FileExists(FName) Then .DeleteFile FName
        ElseIf .FileExists(FName) Then If MsgBox( _
        "Удалить этот файл ?" & vbCrLf & FName, 68) = vbYes Then .DeleteFile FName
        End If
    End With
End Sub
 
Sub test()
    'Эта процедура не нужна, она демонстрирует возможность доступа
    Dim v, result
    On Error Resume Next
    For Each v In ThisWorkbook.VBProject.References
        result = result & vbCrLf & v.Name
    Next
    If Len(result) = 0 Then MsgBox "Доступ к VBA-проекту невозможен", 64: Exit Sub
    v = _
    "Если вы видите этот текст, значит доступ к проекту VBA = Yes" & vbCrLf & _
    "Подключенные библиотеки:"
    MsgBox v & result, 64
End Sub