Makro til vandmærke og skrivebeskyt

Et udkast - koden ligger i en userform, som kan aktiveres via en knap i ark1
- Ellers send en mail til: pb@supertekst-it.dk - som returnere jeg "det hele"

Private Sub CommandButton1_Click()                  'OK
    styringAfVandmærke
    styringAfLås
    Unload UserForm1
End Sub
Private Sub CommandButton2_Click()                  'Annuller
    Unload UserForm1
End Sub
Private Sub styringAfVandmærke()
    If Me.OptionButton1 = True Then
        visVandmærke
    Else
        skjulVandMærke
    End If
End Sub
Private Sub styringAfLås()
    If Me.OptionButton3 = True Then
        lås
    Else
        låsOp
    End If
End Sub
Private Sub visVandmærke()
    ActiveSheet.PageSetup.CenterHeaderPicture.Filename = _
        "C:\Documents and Settings\pb\Skrivebord\2012ExcelVandmærke\udkast.bmp"
End Sub
Private Sub skjulVandMærke()
    ActiveSheet.PageSetup.CenterHeaderPicture.Filename = ""
End Sub
Private Sub lås()
    ActiveSheet.Protect
    ActiveWorkbook.Protect
End Sub
Private Sub låsOp()
    ActiveSheet.Unprotect
    ActiveWorkbook.Unprotect
End Sub
Private Sub UserForm_activate()
    If ActiveSheet.PageSetup.CenterHeaderPicture.Filename <> "" Then
        Me.OptionButton1 = True
    Else
        Me.OptionButton2 = True
    End If
   
    If ActiveSheet.ProtectContents = True Then
        Me.OptionButton3 = True
    Else
        Me.OptionButton4 = True
    End If
End Sub

Ny version:

Rem Version 2
Rem =========
Dim xSti
Private Sub CommandButton1_Click()                  'OK
    styringAfVandmærke
    styringAfLås
    Unload UserForm1
End Sub
Private Sub CommandButton2_Click()                  'Annuller
    Unload UserForm1
End Sub
Private Sub styringAfVandmærke()
    If Me.OptionButton1 = True Then
        visVandmærke
    Else
        skjulVandMærke
    End If
End Sub
Private Sub styringAfLås()
    If Me.OptionButton3 = True Then
        lås
    Else
        låsOp
    End If
End Sub
Private Sub visVandmærke()
    With ActiveWorkbook
        For a = 1 To .Sheets.Count
            Sheets(a).PageSetup.CenterHeaderPicture.Filename = xSti + "udkast.bmp"
            Sheets(a).PageSetup.CenterHeader = "&G"
        Next a
    End With
End Sub
Private Sub skjulVandMærke()
    With ActiveWorkbook
        For a = 1 To .Sheets.Count
            .Sheets(a).PageSetup.CenterHeader = ""
        Next a
    End With
End Sub
Private Sub lås()
    With ActiveWorkbook
        For a = 1 To .Sheets.Count
            Sheets(a).Protect
        Next a
    End With
   
    ActiveWorkbook.Protect
End Sub
Private Sub låsOp()
    With ActiveWorkbook
        For a = 1 To .Sheets.Count
            Sheets(a).Unprotect
        Next a
    End With
   
    ActiveWorkbook.Unprotect
End Sub
Private Sub UserForm_activate()
    findSti
   
    x = ActiveSheet.PageSetup.CenterHeader
   
    If Len(ActiveSheet.PageSetup.CenterHeader) > 0 Then
        Me.OptionButton1 = True
    Else
        Me.OptionButton2 = True
    End If
   
    If ActiveSheet.ProtectContents = True Then
        Me.OptionButton3 = True
    Else
        Me.OptionButton4 = True
    End If
End Sub
Private Sub findSti()
    xSti = ActiveWorkbook.Path
    If Right(xSti, 1) <> "\" Then
        xSti = xSti + "\"
    End If
End Sub

Den laver fejl i denne (private SUb Lås)

Sheets(a).Protect

Men udkast viker på alle sider

Jeg kan se fejlen kommer når jeg har markeret flere ark samtidig. Efter f.eks. udskrivning

Vi kan evt. stryge beskyttelse af de enkelte ark og nøjes med mappen?

Jeps.

Det er nok mig som ikke har forklaret det godt nok.

Det er fint hvis hele mappen bliver skrivebeskyttet (uden password) og man kan ophæve beskyttelsen (uden password)

Hvis du indsætter de to markerede linier i version 2 - så skulle det hjælpe - idet markeringen af flere ark ophæves:

Private Sub lås()
    With ActiveWorkbook
        For a = 1 To .Sheets.Count
            Sheets(a).Select                'TILFØJELSE
            Sheets(a).Protect
        Next a
    End With
   
    ActiveWorkbook.Protect
End Sub
Private Sub låsOp()
    With ActiveWorkbook
        For a = 1 To .Sheets.Count
            Sheets(a).Select                'TILFØJELSE
            Sheets(a).Unprotect
        Next a
    End With
   
    ActiveWorkbook.Unprotect
End Sub

Jeg synes den laver fejl i lige præcis de nye linier når jeg nu prøver. Det gør den også når jeg prøver at indsætte vandmærke ???

Prøv at sende din kode, sådan som den ser ud nu - så kan jeg prøve den...

Dim xSti
Private Sub CommandButton1_Click()                  'OK
    styringAfVandmærke
    styringAfLås
    Unload UserForm1
End Sub
Private Sub CommandButton2_Click()                  'Annuller
    Unload UserForm1
End Sub
Private Sub styringAfVandmærke()
    If Me.OptionButton1 = True Then
        visVandmærke
    Else
        skjulVandMærke
    End If
End Sub
Private Sub styringAfLås()
    If Me.OptionButton3 = True Then
        lås
    Else
        låsOp
    End If
End Sub
Private Sub visVandmærke()
    With ActiveWorkbook
        For a = 1 To .Sheets.Count
            Sheets(a).PageSetup.CenterHeaderPicture.Filename = xSti + "udkast.bmp"
            Sheets(a).PageSetup.CenterHeader = "&G"
        Next a
    End With
End Sub
Private Sub skjulVandMærke()
    With ActiveWorkbook
        For a = 1 To .Sheets.Count
            .Sheets(a).PageSetup.CenterHeader = ""
        Next a
    End With
End Sub
Private Sub lås()
    With ActiveWorkbook
        For a = 1 To .Sheets.Count
            Sheets(a).Select                'TILFØJELSE
            Sheets(a).Protect
        Next a
    End With
   
    ActiveWorkbook.Protect
End Sub
Private Sub låsOp()
    With ActiveWorkbook
        For a = 1 To .Sheets.Count
            Sheets(a).Select                'TILFØJELSE
            Sheets(a).Unprotect
        Next a
    End With
   
    ActiveWorkbook.Unprotect
End Sub
Private Sub UserForm_activate()
    findSti
   
    X = ActiveSheet.PageSetup.CenterHeader
   
    If Len(ActiveSheet.PageSetup.CenterHeader) > 0 Then
        Me.OptionButton1 = True
    Else
        Me.OptionButton2 = True
    End If
   
    If ActiveSheet.ProtectContents = True Then
        Me.OptionButton3 = True
    Else
        Me.OptionButton4 = True
    End If
End Sub
Private Sub findSti()
    xSti = ActiveWorkbook.Path
    If Right(xSti, 1) <> "\" Then
        xSti = xSti + "\"
    End If
End Sub

Får ingen fejl når jeg anvender din kode.
Kunne det tænkes, at din knap, der kalder makroen henviser til en gl. version?

Evt. tag en PrtScr og send billedet når fejlen optræder (efter debug-knappen ar aktiveret)

Alternativt (bedst):
Ellers må du gerne sende hele filen til min mail - det bliver jo ikke jul, hvis det ikke lykkes :-)

Jeg har sendt et skærmprint til dig.

Jeg har lagt makroen over i et andet Excel-ark(der var jeg skal bruge den)

Jeg har både modulet og userformen med.

Din makro virker i det oprindelige ark (vandmærke) men ikke efter jeg har flyttet det.

Dog laver den en mærkeligt ting i vandmærke.xls. Den går til det sidste ark )ark3)ved indsætning af vandmærke og trykker man på vis udskrift skriver den "De markerede sider er blanke".
Jeg har ikke markeret nogle ark.

Har ikke modtaget skærmprint!

"De markerede sider-..." - hvis arket er tomt - så kommer denne melding....

Hej. Denne kode er lige noget for mig, kan bare ikke helt få den til at virke
Jeg har kopieret koden ind i mit ark.

Hvike knapper skal jeg oprette for at få den til at virke

>familienriis - læg din e-mail her eller send en til: pb@supertekst-it.dk - så sender jeg den samlede model, der også indeholder en Userform.

Lukker