Excel Spr. użytkownika, ograniczenie czasowe, włączenie makr

Option Explicit


'własna obsługa zapisu przy zamykaniu skoroszytu oraz przy zapisie jest potrzebna
'do wymuszania otwierania skoroszytu z uruchomionymi makrami

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Dim Odp           As Integer
  'własna obsługa zapisu przy zamykaniu skoroszytu
  If ThisWorkbook.Saved = False Then
    Odp = MsgBox("Czy zapisać zmiany w '" & ThisWorkbook.Name & "'?" & Space(14), _
                 vbYesNoCancel + vbExclamation + vbDefaultButton1)
    Select Case Odp
      Case vbYes
        Call InstallDeinstallSolver(SlvrInstal)
        Call ZapiszPlik
      Case vbNo
        Call InstallDeinstallSolver(SlvrInstal)
        ThisWorkbook.Saved = True
      Case vbCancel
        Cancel = True
    End Select
  End If
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  If SaveAsUI Then  'jl Zapisz jako..., to nie pozwalaj
    MsgBox "Zapis do innego pliku nie jest możliwy!", vbInformation
    Cancel = True
  Else  'jl Zapisz
    Call ZapiszPlik
    'ponieważ skoroszyt został zapisany w procedurze ZapiszPlik
    'to poniższe Cancel=True jest  potrzebne!!!
    'przy braku poniższego, dojdzie do ponownego zapisania skoroszytu
    'ale już z innymi ustawieniami arkuszy!!!
    Cancel = True
  End If
End Sub

Private Sub Workbook_Open()


  If UCase(Environ("USERNAME")) <> UCase("Administrator") Then
    Me.Saved = True
   
MsgBox "Program nie jest przeznaczony dla tego użytkownika!" & String(2, vbCr) & "Teraz nastąpi zamknięcie programu.", vbInformation, "!!! UWAGA !!!"
    Me.Close
  End If

  'po upewnieniu się, że makra działają prawidłowo, usuń apastrof z poniższej linii
  'Application.EnableCancelKey = xlDisabled

  On Error GoTo Workbook_Open_Error
  'ukrycie pola tekstowego w arkuszu Tytuł
  ArkuszTytułowy.Shapes("Tekst o makrach").Visible = False



  'Wersja II
  'gdy przekroczona data - masz 20 sek na zmianę daty
 If Range("'data'!AA1") < Date Then

    MsgBox "       Termin  ważności  testu" & Chr(13) & _
           "            już  wygasł.", vbCritical, "TIME OUT"

    Application.OnTime Now + TimeValue("00:00:20"), "koniec_testu"
  Else
    If MsgBox("Niniejszy dokument przeznaczony jest tylko i wyłącznie" & _
              " (...) " & vbCr & _
              "Czy akceptujesz powyższe warunki?", vbYesNo) = vbNo Then
      ThisWorkbook.Close
    End If
  End If
End Sub



'  If Range("'data'!AA1") < Date Then
'    MsgBox "Termin  ważności wyznaczony przez autora aplikacji już minął!" & vbCr & _
'           "Skontaktuj się z twórcą programu w celu dalszego korzystania z aplikacji.", vbCritical, "Time out"
'    Me.Saved = True
'    ThisWorkbook.Close
'  Else
'    If MsgBox("Niniejszy dokument przeznaczony jest tylko i wyłącznie do użytku wewnętrznego." & String(2, vbCr) & _
'              "Dane zawarte w dokumencie zostały uznane przez autorów za prawdziwe, jednak ani autorzy ani xxxxxxx" & _
'              " nie ponoszą odpowiedzialności za kompletność i prawdziwość danych zawartych w publikacji," & _
'              " jak również za wszelkie szkody powstałe w wyniku wykorzystania niniejszej publikacji" & _
'              " lub zawartych w niej informacji." & String(2, vbCr) & "Czy akceptujesz powyższe warunki?", vbYesNo + vbInformation, _
'              "Info") = vbNo Then
'      Me.Saved = True
'      ThisWorkbook.Close
'    End If
'  End If
 
 
   
 

  'sprawdź czy solver jest włączony
  Call SprawdzSolver

  If SlvrInstal = False Then
    Call InstallDeinstallSolver(True)
  End If

  Call OdkryjArkuszeWgUprawnien
  ActiveWindow.DisplayWorkbookTabs = True


Workbook_Open_Exit:
  'po odkryciu odpowiednich arkuszy, udawaj że nic sie w pliku nie zmieniło
  Me.Saved = True

  On Error GoTo 0
  Exit Sub

Workbook_Open_Error:
  MsgBox "Błąd nr " & Err.Number & vbCr & _
         "Treść błędu: " & _
         "(" & Err.Description & ")" & vbCr & _
         " w procedurze Workbook_Open w VBA Document ThisWorkbook"
  Me.Saved = True
  Me.Close
End Sub

Private Sub OdkryjArkuszeWgUprawnien()
  Dim Sh            As Object

  Application.ScreenUpdating = False
  'zastosowano nazwy kodowe!!!


  'odkryj wszystkie arkusze
  For Each Sh In ThisWorkbook.Sheets
    Sh.Visible = xlSheetVisible
  Next Sh
  'ukryj arkusz Tytuł
  ArkuszTytułowy.Visible = xlSheetVeryHidden

  ActiveWindow.DisplayWorkbookTabs = True
  Application.ScreenUpdating = True
End Sub

Private Sub SprawdzSolver()
  Dim doda          As AddIn

  For Each doda In AddIns
    If doda.Installed Then
      If UCase(doda.Name) = UCase("solver.xla") Then
        SlvrInstal = True
        Exit Sub
      End If
    End If
  Next doda
End Sub

Private Sub InstallDeinstallSolver(Optional Instal As Boolean)
  Dim doda          As AddIn

  On Error GoTo InstallDeinstallSolver_Error

  For Each doda In AddIns
    If UCase(doda.Name) = UCase("solver.xla") Then
      doda.Installed = Instal
      Exit Sub
    End If
  Next doda

InstallDeinstallSolver_Exit:

  On Error GoTo 0
  Exit Sub

InstallDeinstallSolver_Error:
  If Err = 1004 And Instal Then
    MsgBox "Na tym komputerze nie ma zainstalowanego dodatku Solver," & vbCr & _
           "który jest niezbędny do prawidłowego działania programu!" & vbCr & _
           "Proszę zainstalować go z płyty instalacyjnej MS Office." & String(2, vbCr) & _
           "Plik zostanie teraz zamknięty!", vbCritical, "Brak dodatku Solver!"
    Err.Clear
    Me.Saved = True
    Me.Close
  Else
    MsgBox "Błąd nr " & Err.Number & vbCr & _
           "Treść błędu: " & _
           "(" & Err.Description & ")" & vbCr & _
           " w procedurze InstallDeinstallSolver w VBA Document ThisWorkbook"
  End If
  Resume InstallDeinstallSolver_Exit

End Sub

Sub koniec_testu()
  If Range("'data'!AA1") < Date Then

    MsgBox "       Termin  ważności  testu" & Chr(13) & _
           "            już  wygasł.", vbCritical, "TIME OUT"

    With ThisWorkbook
      .Saved = True
      .Close
    End With
  End If
End Sub

On Error GoTo Workbook_Open_Error