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!
. Your advice was usefull. Thx 
