Vba excel protection save as and copying

Davorin

New Member
Joined
Aug 20, 2024
Messages
5
Office Version
  1. 365
Platform
  1. Windows
Hi. I have code written for excel but I want to write something to protect excel file from copying.
I have four bottons, click on each botton hava some action.
Last botton is: Delete all bottons.
Im looking for code which allow to user to save as my excel file after Delete all bottons. Before that save as its not possible.
And second protection is if someone copy excel file to his computer, then excel file can bo open only with password (so in code must be some kind of code thats written the file is can be open only on specific location, othervise password is necessery).
Im new in VBA.
Any ideas?
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
i'll have to give some thought to the first part of your question, but i do use such code as you described in a couple of files i maintain to ensure that no one can even use them unless they are me or the file is saved to a specific location. i hope this might help for your situation:

to set it up, place this code in the file's ThisWorkbook object:

VBA Code:
Private Sub Workbook_Open()

CheckMyAddress

End Sub

next, add these routines to the files's macro module:

VBA Code:
Sub CheckMyAddress()
'Crafted 17 Aug 2017 by Wookiee @ MrExcel

Dim strPathsEnd  As String
Dim strUser      As String

strUser = VBA.UCase(VBA.Environ("USERNAME"))

If strUser = "YourOwnUserName" Then

   Application.Speech.Speak "What is thy bidding, my master?"
   Exit Sub
  
End If

'Set the Secure Root Path name and lengths
strPathsEnd = VBA.Right(ThisWorkbook.Path, 17)  '<change to your folder's file length

If strPathsEnd <> "\Membership Tools" Then  '<change to your folder's name

   VBA.MsgBox "You are not using the correct copy " & _
      "of this file. An explorer window will " & _
      "open where you can find the correct copy.", _
      vbCritical + vbOKOnly, "Sorry!"
     
   ActiveWorkbook.FollowHyperlink _
      "\\put\the\filepath\to\the\correct\copy\of\the\file\here.xlsx"
     
   Call HideyHo
  
End If

End Sub

and

VBA Code:
Sub HideyHo()
'Crafted 10 May 2018 by Wookiee @ MrExcel

If VBA.UCase(VBA.Environ("USERNAME")) = _
   "YourOwnUserName" Then Exit Sub
'Change the value in the quotes to your personal user ID

ThisWorkbook.Close _
   SaveChanges:=False

End Sub
 
Upvote 0
Solution
Thx.
Now when I want to open excel file there is rewquest for pasword. Its ok, only I dont want request for pasword when file is opening on server by different user.
Im not good in programming, only use my logic, some old codes, youtube, google...

I used this code for open on server:

Sub CheckMyAddress()
Dim allowedServerFolder As String
Dim currentPath As String
Dim prompt As String
Dim response As String

' Nastavi dovoljeno mapo na strežniku
allowedServerFolder = "Server" ' Real location on serve

' Preveri trenutno pot do datoteke in odpravi morebitne težave z velikostjo črk
currentPath = Trim(LCase(ThisWorkbook.Path & "\"))

' Preveri, ali trenutna pot ustreza dovoljeni poti (primerja brez razlik v velikosti črk in odstrani odvečne presledke)
If Trim(LCase(allowedServerFolder)) <> currentPath Then
prompt = "Datoteka ni na pravilni lokaciji. Vnesi geslo za nadaljevanje."
response = InputBox(prompt, "Preverjanje integritete")

' Če geslo ni pravilno
If response <> "XXX" Then ' Zamenjaj "XXX" z dejanskim geslom
MsgBox "Napačno geslo! Datoteka bo zaprta.", vbCritical
ThisWorkbook.Close SaveChanges:=False
End If
End If
End Sub

Sub HideyHo()
If VBA.UCase(VBA.Environ("USERNAME")) = "YourOwnUserName" Then Exit Sub
' Zamenjaj "YourOwnUserName" z uporabniškim imenom, če je potrebno

ThisWorkbook.Close SaveChanges:=False
End Sub

And thats code for option Save as is possible when all buttons are deleted (but doesnt work);
I translated some text to english, im using slovene:

Sub IzbrisiGumbe()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
MsgBox "All bottos are deleted. Now you can save file.", vbInformation
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Dim shp As Shape
Dim gumbiOstali As Boolean

gumbiOstali = False

' Preveri, če kateri od gumbov še obstaja
For Each ws In ThisWorkbook.Worksheets
For Each shp In ws.Shapes
If shp.Type = msoShapeRectangle Then ' Preveri pravokotne gumbe
If shp.TextFrame.Characters.Text Like "Vstavi*" Or _
shp.TextFrame.Characters.Text Like "Priprava*" Or _
shp.TextFrame.Characters.Text Like "Izbriši*" Then
gumbiOstali = True
Exit For
End If
End If
Next shp
If gumbiOstali Then Exit For
Next ws

' Če gumbi še obstajajo, prekliči shranjevanje
If gumbiOstali Then
MsgBox "Datoteke ni mogoče shraniti, dokler niso odstranjeni vsi gumbi.", vbCritical
Cancel = True
End If
End Sub
 
Upvote 0
Thx.
Now when I want to open excel file there is rewquest for pasword. Its ok, only I dont want request for pasword when file is opening on server by different user.
Im not good in programming, only use my logic, some old codes, youtube, google...

I used this code for open on server:

Sub CheckMyAddress()
Dim allowedServerFolder As String
Dim currentPath As String
Dim prompt As String
Dim response As String

' Nastavi dovoljeno mapo na strežniku
allowedServerFolder = "Server" ' Real location on serve

' Preveri trenutno pot do datoteke in odpravi morebitne težave z velikostjo črk
currentPath = Trim(LCase(ThisWorkbook.Path & "\"))

' Preveri, ali trenutna pot ustreza dovoljeni poti (primerja brez razlik v velikosti črk in odstrani odvečne presledke)
If Trim(LCase(allowedServerFolder)) <> currentPath Then
prompt = "Datoteka ni na pravilni lokaciji. Vnesi geslo za nadaljevanje."
response = InputBox(prompt, "Preverjanje integritete")

' Če geslo ni pravilno
If response <> "XXX" Then ' Zamenjaj "XXX" z dejanskim geslom
MsgBox "Napačno geslo! Datoteka bo zaprta.", vbCritical
ThisWorkbook.Close SaveChanges:=False
End If
End If
End Sub

Sub HideyHo()
If VBA.UCase(VBA.Environ("USERNAME")) = "YourOwnUserName" Then Exit Sub
' Zamenjaj "YourOwnUserName" z uporabniškim imenom, če je potrebno

ThisWorkbook.Close SaveChanges:=False
End Sub

And thats code for option Save as is possible when all buttons are deleted (but doesnt work);
I translated some text to english, im using slovene:

Sub IzbrisiGumbe()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
MsgBox "All bottos are deleted. Now you can save file.", vbInformation
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Dim shp As Shape
Dim gumbiOstali As Boolean

gumbiOstali = False

' Preveri, če kateri od gumbov še obstaja
For Each ws In ThisWorkbook.Worksheets
For Each shp In ws.Shapes
If shp.Type = msoShapeRectangle Then ' Preveri pravokotne gumbe
If shp.TextFrame.Characters.Text Like "Vstavi*" Or _
shp.TextFrame.Characters.Text Like "Priprava*" Or _
shp.TextFrame.Characters.Text Like "Izbriši*" Then
gumbiOstali = True
Exit For
End If
End If
Next shp
If gumbiOstali Then Exit For
Next ws

' Če gumbi še obstajajo, prekliči shranjevanje
If gumbiOstali Then
MsgBox "Datoteke ni mogoče shraniti, dokler niso odstranjeni vsi gumbi.", vbCritical
Cancel = True
End If
End Sub

I had to get some help translating your Slovene notation, but when I tried your BeforeSave macro, it worked for me. I was curious whether the logic to check for rectangular shapes and their text values was necessary, though? Your IzbrisiGumbe routine deletes all shapes, regardless of shape or text.

This is a version I created which simply loops through the sheets and counts the number of shapes. If there are any, it updates the gumbiOstali value to TRUE and exits the loop. I hope this helps.

VBA Code:
Private Sub Workbook_BeforeSave _
  (ByVal SaveAsUI As Boolean, _
   Cancel As Boolean)

Dim ws           As Worksheet
Dim gumbiOstali  As Boolean  'remainingbuttons

gumbiOstali = False

' Preveri, ce kateri od gumbov še obstaja
' check if any buttons exist
For Each ws In ThisWorkbook.Worksheets

   If ws.Shapes.Count > 0 Then

      gumbiOstali = True
      Exit For

   End If

Next ws

' Ce gumbi še obstajajo, preklici shranjevanje
' If the buttons still exist, cancel the storage
If gumbiOstali Then
   'The file cannot be saved until all the buttons are removed
   MsgBox _
      Prompt:="Datoteke ni mogoce shraniti, dokler niso odstranjeni vsi gumbi.", _
      Buttons:=vbCritical
   Cancel = True
End If

End Sub
 
Upvote 0
Hi. Thank you for all your advice. I change Before Save code with you and still doesnt work. All code for bottons works, your advice for pasword is working at opening, only what I want when users opening on server that password is not need.
Im daily users of excel, know a little about macro. Few weeks ago started excel course, at ending of this course is about macro, vba...
And for advice i ask AI, but its not perfect 🙂
During the carrer I figured a lot about lisp, dont know to write, know hot to put together...
Is possible here to send whole code privatly, if you want to see. If take a lot of your times, I understad.
 
Upvote 0
Hi. Thank you for all your advice. I change Before Save code with you and still doesnt work. All code for bottons works, your advice for pasword is working at opening, only what I want when users opening on server that password is not need.
Im daily users of excel, know a little about macro. Few weeks ago started excel course, at ending of this course is about macro, vba...
And for advice i ask AI, but its not perfect 🙂
During the carrer I figured a lot about lisp, dont know to write, know hot to put together...
Is possible here to send whole code privatly, if you want to see. If take a lot of your times, I understad.
i am glad that i was able to help. :)

i cannot, however, think of a way to set it up so that excel only prompts for password for a certain user because all the VBA logic lies on the "opened" side of the file, so you can't have code that runs to make that determination without first opening the file.

also, this board discourages sharing of files and code outside of the forum, because the idea is for everyone to be able to view the discussion and give anyone the ability to chime in.

if you would like to share more, i encourage you to do so here (either as a response to this message, or if you think it should be considered a different question, as a new thread).

vso srečo!
 
Upvote 0
Hi.
There is vba workbook code from you:

Private Sub Workbook_Open()
CheckMyAddress
End Sub

And these are codes in module:


Sub CheckMyAddress()
Dim allowedServerFolder As String
Dim currentPath As String
Dim prompt As String
Dim response As String

' Nastavi dovoljeno mapo na strežniku folder on server
allowedServerFolder = "P:\Ostalo\aaPRENOS\Davorin\" ' Zamenjaj s pravo potjo na strežniku real location on server

' Preveri trenutno pot do datoteke in odpravi morebitne težave z velikostjo črk check location of file and resolve possible troubles with letters
currentPath = Trim(LCase(ThisWorkbook.Path & "\"))

' Preveri, ali trenutna pot ustreza dovoljeni poti (primerja brez razlik v velikosti črk in odstrani odvečne presledke) check if the location is ok
If Trim(LCase(allowedServerFolder)) <> currentPath Then
prompt = "Datoteka ni na pravilni lokaciji. Vnesi geslo za nadaljevanje."
response = InputBox(prompt, "Preverjanje integritete")

' Če geslo ni pravilno
If response <> "XXX" Then ' Zamenjaj "XXX" z dejanskim geslom I have my password XXX is an example
MsgBox "Napačno geslo! Datoteka bo zaprta.", vbCritical
ThisWorkbook.Close SaveChanges:=False
End If
End If
End Sub

Sub HideyHo()
If VBA.UCase(VBA.Environ("USERNAME")) = "YourOwnUserName" Then Exit Sub
' Zamenjaj "YourOwnUserName" z uporabniškim imenom, če je potrebno

ThisWorkbook.Close SaveChanges:=False
End Sub

Sub UstvariGumbe()
Dim ws As Worksheet
Set ws = ActiveSheet

' Ustvari gumbe Create bottons
Dim gumb1 As Shape
Set gumb1 = ws.Shapes.AddShape(msoShapeRectangle, 10, 10, 150, 30)
gumb1.TextFrame.Characters.Text = "Vstavi predračune"
gumb1.OnAction = "VstaviPredracune"

Dim gumb2 As Shape
Set gumb2 = ws.Shapes.AddShape(msoShapeRectangle, 10, 50, 150, 30)
gumb2.TextFrame.Characters.Text = "Vstavi zavihka SPP in Splošno"
gumb2.OnAction = "VstaviSPPinSplosno"

Dim gumb3 As Shape
Set gumb3 = ws.Shapes.AddShape(msoShapeRectangle, 10, 90, 150, 30)
gumb3.TextFrame.Characters.Text = "Priprava strani za print"
gumb3.OnAction = "PripravaPrint"

Dim gumb4 As Shape
Set gumb4 = ws.Shapes.AddShape(msoShapeRectangle, 10, 130, 150, 30)
gumb4.TextFrame.Characters.Text = "Izbriši vse gumbe"
gumb4.OnAction = "IzbrisiGumbe"
End Sub

Sub VstaviPredracune()
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Dim wb As Workbook
Dim ws As Worksheet

Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = True
fd.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"

If fd.Show = -1 Then
For Each vrtSelectedItem In fd.SelectedItems
Set wb = Workbooks.Open(vrtSelectedItem)
For Each ws In wb.Worksheets
ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next ws
wb.Close False
Next vrtSelectedItem
End If
End Sub

Sub VstaviSPPinSplosno()
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Dim wb As Workbook
Dim ws As Worksheet

Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = True
fd.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"

If fd.Show = -1 Then
For Each vrtSelectedItem In fd.SelectedItems
Set wb = Workbooks.Open(vrtSelectedItem)
For Each ws In wb.Worksheets
ws.Copy After:=ThisWorkbook.Sheets(1)
Next ws
wb.Close False
Next vrtSelectedItem
End If
End Sub

Sub PripravaPrint()
Dim odgovor As VbMsgBoxResult
Dim listIme As String
Dim osnoveNastavitve As Worksheet
Dim ws As Worksheet

odgovor = MsgBox("Ali si že oblikoval/a stran za print?", vbYesNo)

If odgovor = vbYes Then
listIme = InputBox("Po katerem zavihku naj se izvede priprava strani za print?", "Izbira zavihka")

On Error Resume Next
Set osnoveNastavitve = ThisWorkbook.Sheets(listIme)
On Error GoTo 0

If Not osnoveNastavitve Is Nothing Then
For Each ws In ThisWorkbook.Sheets
If ws.Index > 3 Then
ws.PageSetup.PrintArea = osnoveNastavitve.PageSetup.PrintArea
ws.PageSetup.Orientation = osnoveNastavitve.PageSetup.Orientation
ws.PageSetup.Zoom = osnoveNastavitve.PageSetup.Zoom
ws.PageSetup.FitToPagesWide = osnoveNastavitve.PageSetup.FitToPagesWide
ws.PageSetup.FitToPagesTall = osnoveNastavitve.PageSetup.FitToPagesTall
End If
Next ws
Else
MsgBox "Zavihek ni bil najden!", vbExclamation
End If
Else
MsgBox "Prosim oblikuj stran za print", vbInformation
End If
End Sub

Sub IzbrisiGumbe()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
MsgBox "Vsi gumbi so bili izbrisani. Sedaj lahko shranite datoteko.", vbInformation
End Sub

Private Sub Workbook_BeforeSave _
(ByVal SaveAsUI As Boolean, _
Cancel As Boolean)

Dim ws As Worksheet
Dim gumbiOstali As Boolean 'remainingbuttons

gumbiOstali = False

' Preveri, ce kateri od gumbov še obstaja
' check if any buttons exist
For Each ws In ThisWorkbook.Worksheets

If ws.Shapes.Count > 0 Then

gumbiOstali = True
Exit For

End If

Next ws

' Ce gumbi še obstajajo, preklici shranjevanje
' If the buttons still exist, cancel the storage
If gumbiOstali Then
'The file cannot be saved until all the buttons are removed
MsgBox _
prompt:="Datoteke ni mogoce shraniti, dokler niso odstranjeni vsi gumbi.", _
Buttons:=vbCritical
Cancel = True
End If

End Sub

Like I said I would like to have this macro excel file on server, my coworkers can open from server with no sugest for password. When they delete all bottons, than is possible to save as on any location.
I see that you are "expert" in vba. Do you have some advice for begginer, how to start (when I finish my excel course 🙂)
I translated some sentence for you to not lose your time for that.
And sorry for my english, im doing my best.
i am glad that i was able to help. :)

i cannot, however, think of a way to set it up so that excel only prompts for password for a certain user because all the VBA logic lies on the "opened" side of the file, so you can't have code that runs to make that determination without first opening the file.

also, this board discourages sharing of files and code outside of the forum, because the idea is for everyone to be able to view the discussion and give anyone the ability to chime in.

if you would like to share more, i encourage you to do so here (either as a response to this message, or if you think it should be considered a different question, as a new thread).

vso srečo!
 
Upvote 0
I did it 😊. Your advice was usefull. Thx 😉
And for server location I had one / too much.
Begginer mistake 🙃
 
Upvote 0
I see that you are "expert" in vba. Do you have some advice for begginer, how to start (when I finish my excel course 🙂)
I translated some sentence for you to not lose your time for that.
And sorry for my english, im doing my best.
there is no need to apologize for your use of english; you're expressing yourself quite well, especially considering that this is not your native language.

as for advice to beginning excel users, i would say that you're off to a good start here at mrexcel (it was one of the sites which helped answer a lot of my questions when i was learning VBA, and now i know enough to be able to answer (some) other people's questions here).

but i also recommend chandoo.org (for both macro and application topics) and excelmacromastery.com (which focuses specifically on using macros).
 
Upvote 0

Forum statistics

Threads
1,223,880
Messages
6,175,154
Members
452,615
Latest member
bogeys2birdies

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top