"Tving" brugeren til at aktivere makro

Hvis du lægger denne kode i 'Thisworkbook' så har du gjort hvad du kan for at forhindre at brugere åbner uden makroer.

Når bruger åbner uden makroer, vil de kun se arket 'Fejl'

Du skal naturligvis lige ændre navnet på den siden som bruger ser hvis de ikke åbner med makroer, her kaldet 'Fejl'

Private Const UdenMakroArk = "Fejl"

Private Sub Workbook_Open()
On Error Resume Next
For Each ws In Sheets
ws.Visible = True
Next ws

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
For Each ws In Sheets
    If ws.Name <> UdenMakroArk Then
        ws.Visible = xlSheetVeryHidden
    Else
        ws.Visible = xlSheetVisible
    End If
Next ws

ThisWorkbook.Save

End Sub

Ulempen ved denne kode er at arket altid gemmes når det lukkes, det kan man leve med.

Men husk at du har lukket hullet for almindelige brugere, men ikke erfarne 'hajer'

Denne kode kan også findes på: https://www.excel-regneark.dk/?pageIDX=210

//Allan

Hej Sempai,

Fejlen tyder på at du allerede har 1 forekomst af Workbook_BeforeClose

2 makroer må ikke have samme navn, du kan evt. kombinere dem.

//Allan

Hej Sempai,

Husk at som standard hedder arket som skal vises uden makroer 'Fejl', det kan du selv rette i toppen af koden.

Det gøres i constanten UdenMakroArk.

Tving bruger til at åbne med makroer og loggen er samlet herunder:

//Allan

'************ Allan Thustrup Mortensen - Excel-regneark.dk ***********
'*************************************************************
Private Const UdenMakroArk = "Fejl"
Private Const LogFilNavn = "Brugere.log"
Private Const LogFilPlacering = "" 'Hvis tom, gemmes i samme mappe som excelfilen, ellers HUSK at afslutte med
Private Const Gem = True
Private Const Åben = True
Private Const Luk = True
Private Const Udskriv = True
Private Const Ændring_i_Celle = True
Private Const AktiveFane = True

'*************************************************************
Public GammelVærdi As Variant
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Function UserName() As String
     Dim Buffer As String * 100
     Dim BuffLen As Long
     BuffLen = 100
     GetUserName Buffer, BuffLen
     UserName = Left(Buffer, BuffLen - 1)
End Function
Private Sub Workbook_BeforeClose(Cancel As Boolean)

For Each ws In Sheets
    If ws.Name <> UdenMakroArk Then
        ws.Visible = xlSheetVeryHidden
    Else
        ws.Visible = xlSheetVisible
    End If
Next ws

ThisWorkbook.Save

If Gem = True Then
     On Error Resume Next
     If LogFilPlacering = "" Then
         Open ThisWorkbook.Path & Application.PathSeparator & LogFilNavn For Append As #1
     Else
         Open LogFilPlacering & LogFilNavn For Append As #1
     End If
     Print #1, UserName, "LUK", Now
     Close #1
End If
End Sub
Private Sub Workbook_BeforePrint(Cancel As Boolean)
If Udskriv = True Then
     On Error Resume Next
     If LogFilPlacering = "" Then
         Open ThisWorkbook.Path & Application.PathSeparator & LogFilNavn For Append As #1
     Else
         Open LogFilPlacering & LogFilNavn For Append As #1
     End If
     Print #1, UserName, "Udskriv", Now
     Close #1
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Gem = True Then
     On Error Resume Next
     If ThisWorkbook.Saved = False Then
         If LogFilPlacering = "" Then
             Open ThisWorkbook.Path & Application.PathSeparator & LogFilNavn For Append As #1
         Else
             Open LogFilPlacering & LogFilNavn For Append As #1
         End If
         Print #1, UserName, "GEM", Now
         Close #1
     End If
End If
End Sub
Private Sub Workbook_Open()
On Error Resume Next

For Each ws In Sheets
    ws.Visible = True
Next ws

If Åben = True Then

     If LogFilPlacering = "" Then
         Open ThisWorkbook.Path & Application.PathSeparator & LogFilNavn For Append As #1
     Else
         Open LogFilPlacering & LogFilNavn For Append As #1
     End If
     Print #1, UserName, "ÅBEN", Now
     Close #1
End If
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
On Error Resume Next
If AktiveFane = True Then
     If LogFilPlacering = "" Then
         Open ThisWorkbook.Path & Application.PathSeparator & LogFilNavn For Append As #1
     Else
         Open LogFilPlacering & LogFilNavn For Append As #1
     End If
     Print #1, UserName, "Aktiv fane ", Now, Sh.Name
     Close #1
End If
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
If Ændring_i_Celle = True Then
     If LogFilPlacering = "" Then
         Open ThisWorkbook.Path & Application.PathSeparator & LogFilNavn For Append As #1
     Else
         Open LogFilPlacering & LogFilNavn For Append As #1
     End If
     Print #1, UserName, "Ændring", Now, ActiveSheet.Name & " " & Target.AddressLocal, "Fra: " & GammelVærdi, "Til: " & Target.Value
     Close #1
End If
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If ActiveCell.Address <> Target.Address Then Exit Sub
GammelVærdi = Target.Value
End Sub

Navigation

"Tving" brugeren til at aktivere makro