Makro og VBA - "Tving" brugeren til at aktivere makro

"Tving" brugeren til at aktivere makro

Udskrevet fra: Dansk Regneark Forum
Kategori: Hjælp til regneark.
Forum navn: Makro og VBA
Forum beskrivelse: Hjælp til Makroer og VBA-programmering
Web-adresse: https://forum.excel-regneark.dk/forum_posts.asp?TID=515
Udskrevet den: 23.Nov.2024 kl. 17:09

Emne: "Tving" brugeren til at aktivere makro

Besked fra: Sempai
Emne: "Tving" brugeren til at aktivere makro
Posteringsdato: 03.Nov.2011 kl. 10:43

Hej,

Der har tidligere været en tråd her på siden, hvor man kunne "tvinge" brugeren til at aktivere makro, for at kunne se arkene.

Jeg har fundet tråden, men kan ikke se selve koden..

Er der nogen der kan lægge et eksempel op?

Idéen var, at man kunne gøre sådan, at brugeren kun kunne se ét ark, hvis ikke han/hun aktiverede makroer - det var skrevet i VBA, med pålagt password...

Mvh

Svar:

Besked fra: Allan
Posteringsdato: 03.Nov.2011 kl. 12:09

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" >https://www.excel-regneark.dk/?pageIDX=210

//Allan

Besked fra: Sempai
Posteringsdato: 10.Nov.2011 kl. 11:12

Hej Allan,

Har prøvet at sætte koden ind, men for en compile error: Ambiguous name detected: Workbook_BeforeClose...

// Sempai

Besked fra: Allan
Posteringsdato: 10.Nov.2011 kl. 11:36

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

Besked fra: Sempai
Posteringsdato: 10.Nov.2011 kl. 12:32

Har prøvet at kombinere dem, men det er som om det ikke rigtig vil som jeg vil..

Den skal ligge i samme dokument som makroen med log, som skriver til en ekstern logfil..

Den bruger både Workbook_BeforeClose & Workbook_Open()..

Jeg kan godt sætte dem ind, og gemme efter hensigten - men det giver ikke det ønskede resultat.. :-(

Besked fra: Allan
Posteringsdato: 10.Nov.2011 kl. 14:53

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