Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 4d1536d76401b95d…

MALICIOUS

Office (OLE)

1.09 MB Created: 1997-09-15 11:36:16 Authoring application: Microsoft Excel First seen: 2019-08-04
MD5: 9018f6399ae3bc15817888e873ec0457 SHA-1: f215c9dcc470a4db30615aee0704027044bded0c SHA-256: 4d1536d76401b95d2b1889e0c0ba12a9d31e87b3a17e2bb7e2cecd0f792b85f9
286 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1204.002 Malicious File T1566.001 Spearphishing Attachment

This Excel document contains malicious VBA macros, including an Auto_Open subroutine, which are designed to execute arbitrary code. The macros utilize WScript.Shell and CreateObject, indicating an intent to download and execute a second-stage payload. The presence of Auto_Open and the use of Shell() strongly suggest this file was delivered as a spearphishing attachment.

Heuristics 10

  • VBA macros detected medium 7 related findings OLE_VBA_MACROS
    Document contains VBA macro code
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
    Function GetSpecFolder(ShortcutFolder As String) As String
Dim Shell As Object
    Set Shell = CreateObject("WScript.Shell")
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
    Function MatchReg(ByRef RegName, Optional ByVal Title As String)
    Set rg = CreateObject("WScript.Shell")
    If RegName = "[user]" Then
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        End If
    Set fs = CreateObject("Scripting.FileSystemObject")
'    CurrentWork.Worksheets(Range("Modelovani_PDZ").Parent.Name).Buttons("ImportData").Visible = fs.FileExists(ImportDirectory + ImportFile)
  • VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXEC
    Compiled VBA/cache stream contains an auto-execution token together with shell/download/object-execution tokens. This catches p-code-only or source-extraction-failure macro documents where visible source is unavailable.
  • Auto_Open macro low OLE_VBA_AUTO
    Auto_Open macro
    Matched line in script
    End Function
Sub auto_open()
    CountLock = 0
  • Auto_Close macro low OLE_VBA_AUTOCLOSE
    Auto_Close macro
    Matched line in script
    End Sub
Sub Auto_Close()
    If Not ActualizeWorkbook Then Exit Sub
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
        If RegName = "[user]" Then
        MatchReg = Environ("USERNAME")
        If MatchReg = "" Then
  • Reference to Windows Script Host high SC_STR_WSCRIPT
    Reference to Windows Script Host
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://schemas.microsoft.com/office/2006/metadata/longProperties In document text (OLE body)
    • http://schemas.openxmlformats.org/officeDocument/2006/customXmlIn document text (OLE body)
    • http://schemas.microsoft.com/office/2006/metadata/contentTypeIn document text (OLE body)
    • http://schemas.microsoft.com/office/2006/metadata/properties/metaAttributesIn document text (OLE body)
    • http://schemas.microsoft.com/office/2006/metadata/propertiesIn document text (OLE body)
    • http://www.w3.org/2001/XMLSchemaIn document text (OLE body)
    • http://schemas.microsoft.com/sharepoint/v3In document text (OLE body)
    • http://schemas.microsoft.com/office/2006/documentManagement/typesIn document text (OLE body)
    • http://schemas.microsoft.com/office/infopath/2007/PartnerControlsIn document text (OLE body)
    • http://schemas.openxmlformats.org/package/2006/metadata/core-propertiesIn document text (OLE body)
    • http://www.w3.org/2001/XMLSchema-instanceIn document text (OLE body)
    • http://purl.org/dc/elements/1.1/In document text (OLE body)
    • http://purl.org/dc/terms/In document text (OLE body)
    • http://schemas.microsoft.com/internal/obdIn document text (OLE body)
    • http://dublincore.org/schemas/xmls/qdc/2003/04/02/dc.xsdIn document text (OLE body)
    • http://dublincore.org/schemas/xmls/qdc/2003/04/02/dcterms.xsdIn document text (OLE body)
    • http://schemas.microsoft.com/sharepoint/v3/contenttype/formsIn document text (OLE body)

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 144455 bytes
SHA-256: 3f0d8cb0a22eca59483fde12b28087995702a5872f8a99345f2b8bfa6b8f3b07
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "Makro"
Global Const ImportDirectory = "c:\eusml\"
Global Const ImportFile = "Es_Exp.xls"
Public CurFileName, CurSheetName, CurKlient As String
Public isImport As Boolean, initImport As Boolean, isDBAccess, isDbRead As Boolean
Public CountLock As Integer
Public UserPassword As ObjectPassword
Public AdminPassword As ObjectPassword
Public CurrentWork As Workbook
Public WarnButton, WarnBarButton As Object
Public ConnectDb As Connect
Function get_adress(Pozice As Integer) As String
    retstr = ""
    zust = 0
    celk = Pozice
    Do While celk > 0
        zust = celk Mod 26
        If zust = 0 Then
            zust = 26
        End If
        celk = (celk - zust) / 26
        retstr = Chr(64 + zust) + retstr
    Loop
    get_adress = retstr
End Function
Sub auto_open()
    CountLock = 0
    isImport = False
    Set CurrentWork = ActiveWorkbook
    CurrentWorkUnProtect
    ActiveWindow.WindowState = xlMaximized
    CurVerze = "ver. " & CurrentWork.Worksheets("Upgrade").Range("D1").Text & "®"
    
    Upgrade "AdminPassword"
    Application.Calculation = xlCalculationAutomatic
    ErrText = "auto_open isOpened"
    If isOpened Then
       MsgBox "Aplikace " + CurrentWork.Title + " je už otevřena. Nelze ji otevřít znovu", , CurrentWork.Title
       On Error GoTo 0
       CurrentWork.Close (False)
    End If
    ErrCnt = 0
    On Error GoTo ErrAdrReg
    UpgradeDir = GetAdrReg("[application]", CurrentWork.Title)
    UpgradeVer = GetAdrReg("[applicationver]", CurrentWork.Title)
    On Error GoTo 0
    If UpgradeDir = "" Or LCase(UpgradeDir) <> LCase(CurrentWork.FullName) And UpgradeVer <= CurVerze Then
        UpgradeDir = Mid(CurrentWork.FullName, 1, Len(CurrentWork.FullName) - Len(CurrentWork.Name))
        UpgradeName = CurrentWork.Name
        CreateIcons FileDir:=UpgradeDir, FileName:=UpgradeName, test:=True, WorkName:=CurrentWork.Title
        SetAdrReg apRegistry + CurrentWork.Title + "\", CurrentWork.FullName
        SetAdrReg apRegistry + CurrentWork.Title + "\" + apRegistryVer, CurVerze
    End If
    LockSheet
    CurrentWorkProtect
    Application.DisplayAlerts = True
    Application.CellDragAndDrop = False
    If CurrentWork.DisplayDrawingObjects <> xlAll Then CurrentWork.DisplayDrawingObjects = xlAll
    If Not Application.EditDirectlyInCell Then Application.EditDirectlyInCell = True
    If Application.ReferenceStyle <> xlA1 Then Application.ReferenceStyle = xlA1
    CurrentWork.Worksheets(CurrentWork.Sheets("Info").Range("RootSheet").Value).Unprotect Password:=Range("AdminPassword").Cells(1, 1).Value
    CurrentWork.Worksheets(CurrentWork.Sheets("Info").Range("RootSheet").Value).TextBoxes("verze").Text = CurVerze
    For Each MyObject In CurrentWork.Worksheets  ' Iterate through each element.
        If Range("AdminMode").Value Then
            MyObject.Unprotect Password:=Range("AdminPassword").Cells(1, 1).Value
        Else
            MyObject.Protect Password:=Range("AdminPassword").Cells(1, 1).Value
        End If
    Next
    CurrentWorkProtect
    CurrentWork.Sheets("Data").Unprotect Password:=Range("AdminPassword").Cells(1, 1).Value
    initpasswords
 On Error GoTo ErrTisk
    Worksheets(Range("Modelovani_PDZ").Parent.Name).PageSetup.Zoom = False
    Worksheets(Range("Modelovani_PDZ").Parent.Name).PageSetup.FitToPagesWide = 1
    Worksheets(Range("Modelovani_PDZ").Parent.Name).PageSetup.FitToPagesTall = 1
    Worksheets(Range("Slevy_PDZ").Parent.Name).PageSetup.Zoom = False
    Worksheets(Range("Slevy_PDZ").Parent.Name).PageSetup.FitToPagesWide = 1
    Worksheets(Range("Slevy_PDZ").Parent.Name).PageSetup.FitToPagesTall = 1
ErrTisk:
    On Error GoTo 0
    Err.Clear
    Worksheets(Range("Modelovani_PDZ").Parent.Name).Select
    ImportKlient True
    CreateMenu
    
    CurSheetName = Range("Modelovani_PDZ").Parent.Name
    CurFileName = CurrentWork.Name
    Application.OnSheetActivate = CurrentWork.Name & "!Makro.ActivSheet"
    Application.OnEntry = CurrentWork.Name & "!Makro.OnChange"

    isDBAccess = TestConnect
    Worksheets(Range("Modelovani_PDZ").Parent.Name).Buttons("ReadRC").Visible = isDBAccess
    Worksheets(Range("Modelovani_PDZ").Parent.Name).Buttons("ReadSmlouva").Visible = isDBAccess
    Exit Sub
ErrAdrReg:
    If ErrCnt > 0 Then
        Err.Clear
        On Error GoTo 0
    End If
    ErrCnt = ErrCnt + 1
    SetAdrReg apRegistry + CurrentWork.Title + "\", CurrentWork.FullName
    SetAdrReg apRegistry + CurrentWork.Title + "\" + apRegistryVer, CurVerze
    UpgradeDir = Mid(CurrentWork.FullName, 1, Len(CurrentWork.FullName) - Len(CurrentWork.Name))
    UpgradeName = CurrentWork.Name
    CreateIcons FileDir:=UpgradeDir, FileName:=UpgradeName, test:=True, WorkName:=CurrentWork.Title
Resume
End Sub
Sub Auto_Close()
    If Not ActualizeWorkbook Then Exit Sub
    Application.OnSheetActivate = ""
    Application.OnEntry = ""
    Application.CellDragAndDrop = True
    CloseMenu
    Application.DisplayAlerts = False
    If Trim(UserPassword.Password) <> "" Then
        CurrentWork.SaveAs FileName:=CurrentWork.FullName, _
        FileFormat:=xlNormal, Password:=Trim(UserPassword.Password), WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    End If
    If Not IsEmpty(CurrentWork) Then
        CurrentWork.Close (False)
    Else
        ActiveWorkbook.Close (False)
    End If
    Application.DisplayAlerts = True
    Set CurrentWork = Nothing
End Sub
Sub NastavTisk(Optional PrintSheet As Workbook)
    If PrintSheet Is Nothing Then Set PrintSheet = CurrentWork
    PrintSheet.Activate
    SetPrintArea Worksheets(Range("Modelovani_PDZ").Parent.Name), "Oblast_tisku"
End Sub
Sub NastavTisk2(Optional PrintSheet As Workbook)
    If PrintSheet Is Nothing Then Set PrintSheet = CurrentWork
    PrintSheet.Activate
    SetPrintArea Worksheets(Range("Slevy_PDZ").Parent.Name), ""
End Sub
Sub Tisk(Optional PrintSheet As Worksheet)
Dim PrintSheetVisible As Boolean
    Set OldSheet = ActiveSheet
    ActualizeWorkbook (True)
    If PrintSheet Is Nothing Then Set PrintSheet = ActiveSheet
    PrintSheetVisible = PrintSheet.Visible
    Visualsheet PrintSheet, True
    PrintSheet.PrintPreview
    Visualsheet PrintSheet, PrintSheetVisible
    OldSheet.Activate
End Sub
Sub TiskBonity()
    ActualizeWorkbook (True)
    If Range("Disp").Text <> " " Then
        Tisk Worksheets(Range("NezajistenaBonita").Parent.Name)
    Else
        MsgBox "Bonita není spočítana!!", vbCritical, "Tisk bonity"
    End If
End Sub
Sub Email(Optional PrintSheet As Worksheet)
Dim PrintSheetVisible As Boolean
Dim OldBook, NewBook As Workbook
    Set OldSheet = ActiveSheet
    Set OldBook = OldSheet.Parent
    AdminsPassword = Range("AdminPassword").Cells(1, 1).Text
    ActualizeWorkbook (True)
    If PrintSheet Is Nothing Then Set PrintSheet = ActiveSheet
    PrintSheetVisible = PrintSheet.Visible
    Visualsheet PrintSheet, True
    
    PrintSheet.Cells.Select
    Selection.Copy
    Set NewBook = Workbooks.Add
    PrintSheet.Copy Before:=NewBook.Sheets(1)
    ActiveSheet.Unprotect Password:=AdminsPassword
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Cells(1, 1).Select
    ActiveSheet.Name = Trim("Bonita " & Range("jmeno").Text)
    ActiveSheet.Range("R:R", ActiveSheet.Range("R:R").End(xlToRight)).EntireColumn.Hidden = True
'    Columns("R:R").Select
'    Range(Selection, Selection.End(xlToRight)).Select
'    Selection.EntireColumn.Hidden = True
'    NewBook.Sheets(1).Columns("R:IV").Width = 0
    
    ActiveSheet.Protect Password:=AdminsPassword
    OldAllerts = Application.DisplayAlerts
    Application.DisplayAlerts = False
    MaxCounts = NewBook.Sheets.Count - 1
'    NewBook.SaveAs ActiveSheet.Name & ".xls", xlExcel5
'    NewName = NewBook.FullName
    For i = 1 To MaxCounts
        NewBook.Sheets(2).Delete
    Next
    Application.DisplayAlerts = OldAllerts
    Application.Dialogs(xlDialogSendMail).Show "", "Bonita " & Range("jmeno").Text
    NewBook.Close False
    Visualsheet PrintSheet, PrintSheetVisible
    OldSheet.Activate
End Sub
Sub EmailBonity()
    ActualizeWorkbook (True)
    If Range("Disp").Text <> " " Then
        Email Worksheets(Range("NezajistenaBonita").Parent.Name)
    Else
        MsgBox "Bonita není spočítana!!", vbCritical, "Bonita poštou"
    End If
End Sub

Sub TiskDAPObrat()
     ActualizeWorkbook (True)
     Tisk Worksheets(Range("DapVypocet").Parent.Name)
'    Worksheets(Range("DapVypocet").Parent.Name).Visible = xlSheetHidden
End Sub
Sub TiskDAPZaklad()
    ActualizeWorkbook (True)
    Tisk Worksheets(Range("OsvcVypocet").Parent.Name)
'    Worksheets(Range("OsvcVypocet").Parent.Name).Visible = xlSheetHidden
End Sub
Sub TiskManzelZaklad()
    ActualizeWorkbook (True)
    Tisk Worksheets(Range("ManzelVypocet").Parent.Name)
'    Worksheets(Range("OsvcVypocet").Parent.Name).Visible = xlSheetHidden
End Sub
Sub TiskSportZaklad()
    ActualizeWorkbook (True)
    Tisk Worksheets(Range("SportVypocet").Parent.Name)
'    Worksheets(Range("OsvcVypocet").Parent.Name).Visible = xlSheetHidden
End Sub
Sub TiskBonity2(Optional PrintSheet As Workbook)
    If PrintSheet Is Nothing Then Set PrintSheet = CurrentWork
    PrintSheet.Activate
    If Sheets("Tisk").Show Then
       If Sheets("Tisk").EditBoxes(1).Text > 0 Then
          Worksheets("Bonita").PrintOut Copies:=Sheets("Tisk").EditBoxes(1).Text
       End If
    End If
End Sub

Sub ZadatelS()
    UnlockSheet
    Worksheets(Range("Modelovani_PDZ").Parent.Name).Select
'    Range("RodCis").Select
    Range("RodCis").Select
    Worksheets(Range("Modelovani_PDZ").Parent.Name).CheckBoxes("stpod").Visible = True
    Worksheets(Range("Modelovani_PDZ").Parent.Name).CheckBoxes("nemovitost").Visible = True
    Worksheets(Range("Modelovani_PDZ").Parent.Name).CheckBoxes("pojisteni").Visible = True
    
    CountVlogs
    SaveKlient
    Range("Model").Value = 1
    LoadKlient
    Range("OblastRucitelu").Rows.Select
    Selection.EntireRow.Hidden = True
    Range("Oblast_Klienta").Rows.Select
    Selection.EntireRow.Hidden = False
    Range("RodCis").Select
    LockSheet
End Sub
Sub CountVlogs()
 If IsNumeric(Range("TypPreklenovaku").Value) And IsNumeric(Range("NumUverKlienta").Value) And IsNumeric(Range("ProcentoNasporeni").Value) Then
    UnlockSheet
    If Range("DatumZadosti").Value >= 37865 And Range("UverKlienta").Value = "P" And Range("TypPreklenovaku").Value = 8 Then
        Range("MesVkladSS").Value = Range("CilovaCastka").Value * 0.3 / 100
    Else
        If Range("TypPreklenovaku").Text <> " " And Not IsError(Range("VklSS").Value) Then
            If (Range("TypPreklenovaku").Value <> 3 Or Range("DatumZadosti").Value >= 40911) And Range("UverKlienta").Value = "P" And Range("ProcentoNasporeni").Value < Range("VklSS").Value Then
                Range("MesVkladSS").Value = Range("MinMesVkladSS").Value
            Else
                Range("MesVkladSS").Value = 0
            End If
        Else
            Range("MesVkladSS").Value = 0
        End If
    End If
    LockSheet
 End If
End Sub
Sub RucitelS()
    UnlockSheet
    Worksheets(Range("Modelovani_PDZ").Parent.Name).CheckBoxes("stpod").Visible = False
    Worksheets(Range("Modelovani_PDZ").Parent.Name).CheckBoxes("nemovitost").Visible = False
    Worksheets(Range("Modelovani_PDZ").Parent.Name).CheckBoxes("pojisteni").Visible = False
    SaveKlient
    For i = 2 To Range("PocetOsob").Value
        If Worksheets(Range("Modelovani_PDZ").Parent.Name).OptionButtons("osoba" + Trim(Str(i))) = xlOn Then
            Range("Model").Value = i
            Exit For
        End If
    Next
    LoadKlient
    Range("OblastRucitelu").Rows.Select
    Selection.EntireRow.Hidden = False
    Range("Oblast_Klienta").Rows.Select
    Selection.EntireRow.Hidden = True
    LockSheet
    Range("RodCis").Select
End Sub
Sub SaveKlient()
    OffsetRange = Range("Model").Value
    ColumnSave = Range("ZapisOsoby").Column
    SheetName = Range("ZapisOsoby").Parent.Name
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave).Value = Range("Jmeno").Value
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 1).Value = "'" & Range("RodCis").Value
    If OffsetRange > 1 Then
         Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 2).Value = Range("Adresa").Value
         Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 3).Value = Range("PSC").Value
         Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 4).Value = Range("Mesto").Value
    End If
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 5).Value = Range("PrijemZadatel").Value
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 6).Value = Range("PrijemManzel").Value
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 7).Value = Range("PrijemRodina").Value
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 8).Value = Range("PocetDeti6").Value
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 9).Value = Range("PocetDeti10").Value
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 10).Value = Range("PocetDeti15").Value
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 11).Value = Range("PocetDeti26").Value
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 12).Value = Range("PocetDospely").Value
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 13).Value = Range("MesFinZavazku").Value
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 14).Value = Range("Poznamky").Value
    Worksheets(SheetName).Cells(OffsetRange, ColumnSave + 15).Value = Range("Disp").Value
End Sub
Sub LoadKlient()
    OffsetRange = Range("Model").Value
    ColumnLoad = Range("ZapisOsoby").Column
    SheetName = Range("ZapisOsoby").Parent.Name
    Range("Jmeno").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad).Value
    Range("RodCis").Value = "'" & Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 1).Value
    If OffsetRange > 1 Then
       Range("Adresa").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 2).Value
        Range("PSC").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 3).Value
        Range("Mesto").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 4).Value
    End If
    Range("PrijemZadatel").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 5).Value
    Range("PrijemManzel").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 6).Value
    Range("PrijemRodina").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 7).Value
    Range("PocetDeti6").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 8).Value
    Range("PocetDeti10").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 9).Value
    Range("PocetDeti15").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 10).Value
    Range("PocetDeti26").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 11).Value
    Range("PocetDospely").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 12).Value
    Range("MesFinZavazku").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 13).Value
    Range("Poznamky").Value = Worksheets(SheetName).Cells(OffsetRange, ColumnLoad + 14).Value
End Sub
Sub UpdateVis()
    If Not ActualizeWorkbook Then Exit Sub
    Application.OnSheetActivate = CurrentWork.Name & "!Makro.ActivSheet"
    UnlockSheet
    NameSheet = Range("Modelovani_PDZ").Parent.Name
    CountVlogs
    LockSheet
End Sub

Sub ActivSheet()
    If Not ActualizeWorkbook Then Exit Sub
    If CurrentWork.Name <> ActiveWorkbook.Name Then Exit Sub
    If CurrentWork.Sheets(GetWorkSheetByName(CurrentWork, "AdminMode")).Range("AdminMode").Value Then Exit Sub
    On Error GoTo ErrorNazev
    If ActiveSheet.Name <> Range("Modelovani_PDZ").Parent.Name And ActiveSheet.Name <> Range("Slevy_PDZ").Parent.Name And ActiveSheet.Name <> Range("DapVypocet").Parent.Name And ActiveSheet.Name <> Range("OsvcVypocet").Parent.Name And ActiveSheet.Name <> Range("SportVypocet").Parent.Name And ActiveSheet.Name <> Range("ManzelVypocet").Parent.Name Then
       ActName = ActiveSheet.Name
       Sheets(Range("Modelovani_PDZ").Parent.Name).Select
       If Not chk_heslo(Range("AdminPassword").Cells(1, 1).Value, Range("AdminPassword").Cells(13, 1).Text, Range("AdminPassword").Cells(14, 1).Text) Then
          ActiveSheet.Parent.Unprotect Password:=Range("AdminPassword").Cells(1, 1).Value
          Sheets(ActName).Visible = False
          If Not Range("AdminMode").Value Then ActiveSheet.Parent.Protect Password:=Range("AdminPassword").Cells(1, 1).Value
       Else
          Sheets(ActName).Select
       End If
    End If
    On Error GoTo 0
Exit Sub
ErrorNazev:
CurSheetName = Range("Modelovani_PDZ").Parent.Name
Sheets(CurSheetName).Select
Resume Next
End Sub

Sub Schovat_Chybu()
    ActualizeWorkbook (True)
    UnlockSheet
    If Range("Hlaseny_chyby").Font.ColorIndex = 3 Then
       Range("Hlaseny_chyby").Font.ColorIndex = 2
       Range("Hlaseni_dosporovani").Font.ColorIndex = 2
       Worksheets(Range("Modelovani_PDZ").Parent.Name).Buttons("Schovat").Caption = "Ukázat "
       If Not IsEmpty(WarnButton) Then
        If Not WarnButton Is Nothing Then
             WarnButton.FaceId = 463
             WarnButton.Caption = "Povolit chybové hlášky"
        End If
       End If
       If Not IsEmpty(WarnBarButton) Then
        If Not WarnBarButton Is Nothing Then
           WarnBarButton.FaceId = 463
           WarnBarButton.Caption = "Povolit chybové hlášky"
        End If
       End If
    Else
       Range("Hlaseny_chyby").Font.ColorIndex = 3
       Range("Hlaseni_dosporovani").Font.ColorIndex = 3
       Worksheets(Range("Modelovani_PDZ").Parent.Name).Buttons("Schovat").Caption = "Schovat"
       If Not IsEmpty(WarnButton) Then
        If Not WarnButton Is Nothing Then
             WarnButton.FaceId = 330
             WarnButton.Caption = "Zakázat chybové hlášky"
        End If
       End If
       If Not IsEmpty(WarnBarButton) Then
        If Not WarnBarButton Is Nothing Then
           WarnBarButton.FaceId = 330
           WarnBarButton.Caption = "Zakázat chybové hlášky"
        End If
       End If
    End If
    LockSheet
End Sub
Function ChkDatumZalozeni(ADatum As Date) As Integer
ChkDatumZalozeni = 0
If ADatum < DateSerial(2002, 11, 1) Then
    ChkDatumZalozeni = 2
End If
If ADatum >= DateSerial(2002, 11, 1) And ADatum < DateSerial(2004, 4, 1) Then
    ChkDatumZalozeni = 3
End If
If ADatum >= DateSerial(2004, 4, 1) Then
    ChkDatumZalozeni = 4
End If
End Function
Public Sub ChoiceData()
Dim c As Range
    rc = Trim(DialogSheets("Choice").DropDowns("RC").Text)
    Smlouva = Trim(DialogSheets("Choice").DropDowns("Smlouva").Text)
    
    DataKlient = Range("NumDataKlient").Value
    If rc <> "" Then
        RangeVal = "B"
        Ranges = "B:B"
        SearcheS = rc
    End If
    
    If Smlouva <> "" Then
        RangeVal = get_adress(3 + 5 * DataKlient)
        Ranges = RangeVal + ":" + RangeVal
        SearcheS = Smlouva
    End If
    If SearcheS <> "" Then
       Set CurSheet = Worksheets(Range("Modelovani_PDZ").Parent.Name)
       CurSheet.Parent.Unprotect Password:=Range("AdminPassword").Cells(1, 1).Value
       Worksheets("Data").Unprotect Password:=Range("AdminPassword").Cells(1, 1).Value
       Set NewSheet = Sheets.Add
       NewSheet.Visible = False
       On Error GoTo ErrorOpen
       NewSheet.Name = "Temp"
       On Error GoTo 0
       CurSheet.Select
       With Worksheets("Data").Range(Ranges)
            .Columns.AutoFit
            Set c = .Find(SearcheS, LookIn:=xlValues, After:=Worksheets("Data").Range(RangeVal + "1"), SearchOrder:=xlByColumns)
            CountC = 0
            Row = 0
            If Not c Is Nothing Then
            Do While Not c Is Nothing And c.Row > Row
               CountC = CountC + 1
               NewSheet.Cells(CountC, 1).Value = c.Row
               NewSheet.Cells(CountC, 2).Value = c.Offset(0, 1 + 5 * DataKlient).Value
               Row = c.Row
               Set c = .FindNext(c)
            Loop
            End If
            Row = 0
            If CountC > 0 Then
               Row = c.Row
               If CountC > 1 Then
                  DialogSheets("List").ListBoxes("Seznam").ListFillRange = "Temp!B1:B" + Trim(Str(CountC))
                  DialogSheets("List").ListBoxes("Seznam").LinkedCell = "Temp!C1"
                  DialogSheets("List").ListBoxes("Seznam").ListIndex = 1
                  Rets = DialogSheets("List").Show
                  If Rets Then
                     If Not IsEmpty(NewSheet.Range("C1").Value) Then
                        Row = NewSheet.Range("A" + Trim(Str(NewSheet.Range("C1").Value))).Value
                      Else
                        Row = 0
                      End If
                  Else
                     Row = 0
                  End If
               End If
               If Row > 0 Then
                  LoadData (Row)
               End If
            Else
               MsgBox "Neexistuje záznam!", , "Výběr"
            End If
       End With
       Application.DisplayAlerts = False
       NewSheet.Delete
       Application.DisplayAlerts = True
       DialogSheets("Choice").Hide
       If Not Range("AdminMode").Value Then Worksheets("Data").Protect Password:=Range("AdminPassword").Cells(1, 1).Value
       If Not Range("AdminMode").Value Then CurSheet.Parent.Protect Password:=Range("AdminPassword").Cells(1, 1).Value
    Else
       MsgBox "Zadejte, prosím hodnotu pro výběr!", , "Výběr"
    End If
    Exit Sub
ErrorOpen:
    Application.DisplayAlerts = False
    Worksheets("Temp").Delete
    Application.DisplayAlerts = True
    NewSheet.Name = "Temp"
    Resume Next
End Sub
Public Sub ReadData()
    ActualizeWorkbook (True)
    DialogSheets("Choice").DropDowns("RC").Text = ""
    DialogSheets("Choice").DropDowns("Smlouva").Text = ""
    DialogSheets("Choice").DropDowns("RC").ListFillRange = "Data!$B2:$B65536"
    DialogSheets("Choice").DropDowns("Smlouva").ListFillRange = "Data!$BZ2:$BZ65536"
    DialogSheets("Choice").Show
End Sub
Public Sub LoadData(Addr As Integer)
    UnlockSheet
    CurKlient = Trim(Str(Addr))
    DataKlient = Range("NumDataKlient").Value
    ColumnLoad = Range("ZapisOsoby").Column
    RowLoad = Range("ZapisOsoby").Row - 1
    SheetName = Range("ZapisOsoby").Parent.Name
    For j = RowLoad To RowLoad + Range("PocetOsob").Value
        For i = 1 To Range("NumDataKlient").Value
          Worksheets(SheetName).Cells(j + 1, ColumnLoad + i - 1).Value = Worksheets("Data").Range(get_adress(i + j * DataKlient) + CurKlient).Value
        Next
    Next
    Range("DatumZadosti").Value = Worksheets("Data").Range(get_adress(1 + 5 * DataKlient) + CurKlient).Value
    Range("DatumSporeni").Value = Worksheets("Data").Range(get_adress(2 + 5 * DataKlient) + CurKlient).Value
    Range("CisloSmlouvy").Value = Worksheets("Data").Range(get_adress(3 + 5 * DataKlient) + CurKlient).Value
    Range("DatumSmlouvy").Value = Worksheets("Data").Range(get_adress(4 + 5 * DataKlient) + CurKlient).Value
    Range("CilovaCastka").Value = Worksheets("Data").Range(get_adress(5 + 5 * DataKlient) + CurKlient).Value
    Range("NTarif").Value = GetNameTarif(Worksheets("Data").Range(get_adress(6 + 5 * DataKlient) + CurKlient).Value)
    Range("Saldo").Value = Worksheets("Data").Range(get_adress(7 + 5 * DataKlient) + CurKlient).Value
    Range("UkZhodnoceni").Value = Worksheets("Data").Range(get_adress(8 + 5 * DataKlient) + CurKlient).Value
    UpdateVis
    Range("MesVkladSS").Value = Worksheets("Data").Range(get_adress(13 + 5 * DataKlient) + CurKlient).Value
    If IsEmpty(Worksheets("Data").Range(get_adress(14 + 5 * DataKlient) + CurKlient).Value) Then
        Range("DatumNavrhu").Value = DateValue(Range("DatumSmlouvy").Text)
    Else
        Range("DatumNavrhu").Value = DateValue(Worksheets("Data").Range(get_adress(14 + 5 * DataKlient) + CurKlient).Value)
    End If
    
    Range("NazevUveru").Value = Worksheets(Range("PodUvery").Parent.Name).Cells(Range("PodUvery").Row + Worksheets("Data").Range(get_adress(10 + 5 * DataKlient) + CurKlient).Value - 1, Range("PodUvery").Column).Value
    Range("NazevPreklenovaku").Value = Worksheets(Range("PreklenovaciUvery").Parent.Name).Cells(Range("PreklenovaciUvery").Row + Worksheets("Data").Range(get_adress(11 + 5 * DataKlient) + CurKlient).Value - 1, Range("PreklenovaciUvery").Column).Value
    
    CountVlogs
    LoadKlient
    isImport = False
    initImport = False
'    GetTarif
    LockSheet
End Sub
Public Sub NewData(Optional FormatSml As Boolean)
    isDbRead = FormatSml
    ActualizeWorkbook (True)
    CurKlient = "0"
    UnlockSheet
    ClearDap
    ClearOSVC
    Range("ZapisOsoby").ClearContents
    Range("DatumZadosti").ClearContents
    Range("DatumSporeni").ClearContents
    Range("DatumNavrhu").ClearContents
    Range("CisloSmlouvy").ClearContents
    Range("DatumSmlouvy").ClearContents
'    Range("NTarif").ClearContents
    Range("D16:G16").ClearContents
    Range("CilovaCastka").ClearContents
    Range("Saldo").ClearContents
    Range("UkZhodnoceni").ClearContents
    Range("MesVkladSS").ClearContents
    Range("ZajisteniNemovitosti").ClearContents
    Range("PorizeniNemovitosti").ClearContents
    Range("Zastava_Nemovitosti").Value = False
    Range("Zastava_Nemovitosti100").Value = False
    Range("Pojiteni_uveru").Value = False
    Range("prcuhrada").Value = False
    Range("STATNI_PODPORA").Value = False
    UpdateVis
    LockSheet
    LoadKlient
    CountVlogs
    isImport = False
    initImport = False
    Range("DatumZadosti").Value = Date
    Worksheets(Range("Modelovani_PDZ").Parent.Name).Select
    Range("RodCis").Select
    FormatSmlouvy FormatSml
End Sub

Public Sub DeleteData()
    ActualizeWorkbook (True)
    If IsEmpty(CurKlient) Or CurKlient = "0" Then
        MsgBox "Musí se prvně načíst záznam z databáze."
        Exit Sub
    End If
    If MsgBox("Opravdu chcete vymazat smlouvu " + "" + " z databáze?", vbOKCancel) = vbOK Then
        Worksheets("Data").Unprotect Password:=Range("AdminPassword").Cells(1, 1).Value
        Worksheets("Data").Range("A" + CurKlient + ":CC" + CurKlient).Delete (xlShiftUp)
        If Not Range("AdminMode").Value Then Worksheets("Data").Protect Password:=Range("AdminPassword").Cells(1, 1).Value
        CurKlient = "0"
    End If
End Sub
Public Sub WriteData()
    ActualizeWorkbook (True)
    If IsEmpty(Range("CisloSmlouvy").Value) Or LCase(Trim(Range("CisloSmlouvy").Value)) = "klient" Then
        MsgBox "Smlouva není uvedená! Nelze zapsat.", , "Zápis"
        Exit Sub
    End If
    If IsEmpty(CurKlient) Then
        CurKlient = "0"
    End If
    DataKlient = Range("NumDataKlient").Value
    ColumnLoad = Range("ZapisOsoby").Column
    RangeVal = get_adress(3 + 5 * DataKlient)
    Worksheets("Data").Unprotect Password:=Range("AdminPassword").Cells(1, 1).Value
    With Worksheets("Data").Range(RangeVal & ":" & RangeVal)
        .Columns.AutoFit
        Set c = .Find(Range("CisloSmlouvy").Value, LookIn:=xlValues)
        If Not c Is Nothing Then
            Row = 0
            Do While c.Value <> Range("CisloSmlouvy").Value And c.Value <> "" And c.Row > Row
                Row = c.Row
                Set c = .FindNext(c)
            Loop
        End If
        If Not c Is Nothing And IIf(Not c Is Nothing, c, 0) = Range("CisloSmlouvy").Value Then
           If CurKlient = "0" Then
              If MsgBox("Záznam s touto smlouvou existuje! Přepsat záznam?", vbYesNo, "Zápis") = vbYes Then
                 CurKlient = Trim(Str(c.Row))
              Else
                 If Not Range("AdminMode").Value Then .Protect Password:=Range("AdminPassword").Cells(1, 1).Value
                 Exit Sub
              End If
           Else
              If CurKlient <> Trim(Str(c.Row)) Then
                If MsgBox("Existuje jiný záznam smlouvy " & c.Value & ". Má se informace zapsat do něho?", vbYesNo, "Zápis") = vbYes Then
                    CurKlient = Trim(Str(c.Row))
                Else
                    If Not Range("AdminMode").Value Then .Protect Password:=Range("AdminPassword").Cells(1, 1).Value
                    MsgBox ("Smlouva " & c.Value & " nebyla zapsaná!!!")
                    Exit Sub
                End If
              End If
           End If
        Else
            If CurKlient = "0" Then
               Set c = .End(xlDown)
               If c.Row >= 65536 Then
                  Set c = .End(xlUp)
               End If
               If c.Row = 1 Then
                  c.Value = "Smlouva"
               End If
               If c Is Nothing Then
                  CurKlient = "2"
               Else
                  CurKlient = Trim(Str(c.Row + 1))
               End If
            Else
                If Range("CisloSmlouvy").Value <> Worksheets("Data").Range(RangeVal + CurKlient).Value Then
                    If MsgBox("Záznam v databázi je s jinou smlouvou!!!" & vbCrLf & "Chcete přepsat smlouvu " + Worksheets("Data").Range(RangeVal + CurKlient).Text + " se smlouvou " + Range("CisloSmlouvy").Text + "?", vbYesNo) = vbNo Then
                    Set c = .End(xlDown)
                       If c.Row >= 65536 Then
                          Set c = .End(xlUp)
                       End If
                       If c.Row = 1 Then
                          c.Value = "Smlouva"
                       End If
                       If c Is Nothing Then
                          CurKlient = "2"
                       Else
                          CurKlient = Trim(Str(c.Row + 1))
                       End If
                    End If
                End If
            End If
        End If
    End With
    OffsetRange = Range("Model").Value - 1
    Worksheets("Data").Range(get_adress(1 + OffsetRange * DataKlient) + CurKlient).Value = Range("Jmeno").Value
    Worksheets("Data").Range(get_adress(2 + OffsetRange * DataKlient) + CurKlient).Value = "'" & Range("RodCis").Value
    Worksheets("Data").Range(get_adress(3 + OffsetRange * DataKlient) + CurKlient).Value = Range("Adresa").Value
    Worksheets("Data").Range(get_adress(4 + OffsetRange * DataKlient) + CurKlient).Value = Range("PSC").Value
    Worksheets("Data").Range(get_adress(5 + OffsetRange * DataKlient) + CurKlient).Value = Range("Mesto").Value
    Worksheets("Data").Range(get_adress(6 + OffsetRange * DataKlient) + CurKlient).Value = Range("PrijemZadatel").Value
    Worksheets("Data").Range(get_adress(7 + OffsetRange * DataKlient) + CurKlient).Value = Range("PrijemManzel").Value
    Worksheets("Data").Range(get_adress(8 + OffsetRange * DataKlient) + CurKlient).Value = Range("PrijemRodina").Value
    Worksheets("Data").Range(get_adress(9 + OffsetRange * DataKlient) + CurKlient).Value = Range("PocetDeti6").Value
    Worksheets("Data").Range(get_adress(10 + OffsetRange * DataKlient) + CurKlient).Value = Range("PocetDeti10").Value
    Worksheets("Data").Range(get_adress(11 + OffsetRange * DataKlient) + CurKlient).Value = Range("PocetDeti15").Value
    Worksheets("Data").Range(get_adress(12 + OffsetRange * DataKlient) + CurKlient).Value = Range("PocetDeti26").Value
    Worksheets("Data").Range(get_adress(13 + OffsetRange * DataKlient) + CurKlient).Value = Range("PocetDospely").Value
    Worksheets("Data").Range(get_adress(14 + OffsetRange * DataKlient) + CurKlient).Value = Range("MesFinZavazku").Value
    Worksheets("Data").Range(get_adress(15 + OffsetRange * DataKlient) + CurKlient).Value = Range("Poznamky").Value
    
    ColumnLoad = Range("ZapisOsoby").Column
    RowLoad = Range("ZapisOsoby").Row - 1
    For j = RowLoad To RowLoad + Range("PocetOsob").Value
      If OffsetRange <> j Then
        For i = 1 To Range("NumDataKlient").Value
          Worksheets("Data").Range(get_adress(i + j * DataKlient) + CurKlient).Value = Worksheets(Range("ZapisOsoby").Parent.Name).Cells(j + 1, ColumnLoad + i - 1).Value
        Next
      End If
    Next
    
    Worksheets("Data").Range(get_adress(1 + 5 * DataKlient) + CurKlient).Value = Range("DatumZadosti").Value
    Worksheets("Data").Range(get_adress(2 + 5 * DataKlient) + CurKlient).Value = Range("DatumSporeni").Value
    Worksheets("Data").Range(get_adress(3 + 5 * DataKlient) + CurKlient).Value = Range("CisloSmlouvy").Value
    Worksheets("Data").Range(get_adress(4 + 5 * DataKlient) + CurKlient).Value = Range("DatumSmlouvy").Value
    Worksheets("Data").Range(get_adress(5 + 5 * DataKlient) + CurKlient).Value = Range("CilovaCastka").Value
    Worksheets("Data").Range(get_adress(6 + 5 * DataKlient) + CurKlient).Value = Range("Tarif").Value
    Worksheets("Data").Range(get_adress(7 + 5 * DataKlient) + CurKlient).Value = Range("Saldo").Value
    Worksheets("Data").Range(get_adress(8 + 5 * DataKlient) + CurKlient).Value = Range("UkZhodnoceni").Value
    Worksheets("Data").Range(get_adress(10 + 5 * DataKlient) + CurKlient).Value = Range("NumUverKlienta").Value
    Worksheets("Data").Range(get_adress(11 + 5 * DataKlient) + CurKlient).Value = Range("TypPreklenovaku").Value
    Worksheets("Data").Range(get_adress(13 + 5 * DataKlient) + CurKlient).Value = Range("MesVkladSS").Value
    Worksheets("Data").Range(get_adress(14 + 5 * DataKlient) + CurKlient).Value = Range("DatumNavrhu").Value
    If Not Range("AdminMode").Value Then Worksheets("Data").Protect Password:=Range("AdminPassword").Cells(1, 1).Value
    MsgBox "Záznam byl zapsán!", , "Zápis"

End Sub
Function GetValueByName(FindName As String, ByVal FindBook As Workbook, ByVal RowExp As Integer) As Variant
    Set FindCell = FindBook.Worksheets("ES_EXP").Range("1:1").Find(FindName, LookIn:=xlValues, LookAt:=xlWhole)
    If Not FindCell Is Nothing Then GetValueByName = FindCell.Cells(RowExp, 1).Value
End Function
Sub ImportKlient(Optional NoTest As Boolean)

    Dim RowPosition As Integer
    NewData
    If CurrentWork.Worksheets(Range("Modelovani_PDZ").Parent.Name).OptionButtons("osoba1") = xlOff Then
        CurrentWork.Worksheets(Range("Modelovani_PDZ").Parent.Name).OptionButtons("osoba1") = xlOn
        ZadatelS
    End If
    Set fs = CreateObject("Scripting.FileSystemObject")
'    CurrentWork.Worksheets(Range("Modelovani_PDZ").Parent.Name).Buttons("ImportData").Visible = fs.FileExists(ImportDirectory + ImportFile)
    If Not CurrentWork.Worksheets(Range("Modelovani_PDZ").Parent.Name).Buttons("ImportData").Enabled Then GoTo ErrorCentrala
    If fs.FileExists(ImportDirectory + ImportFile) Then
       On Error GoTo ErrorOpen
        Workbooks.Open ImportDirectory + ImportFile
        Set DataWork = ActiveWorkbook
        On Error GoTo 0
    Else
        If Not NoTest Then MsgBox ("Neexistuje soubor " + ImportDirectory + ImportFile)
        Exit Sub
    End If
    CurrentWork.Activate
    RowPosition = 2
    If GetValueByName("stav", DataWork, RowPosition) <> "L" Then
        If MsgBox("Smlouva " & GetValueByName("smlouva", DataWork, RowPosition) & " není platná. Pokračovat?", vbYesNo + vbExclamation) = vbNo Then
            Exit Sub
        End If
    End If
    Range("Jmeno").Value = Trim(GetValueByName("onazev", DataWork, RowPosition)) 'Jméno klienta
    Range("RodCis").Value = "'" & Trim(GetValueByName("id", DataWork, RowPosition)) 'RČ klienta
    
    DatumSporeni = GetValueByName("datexp", DataWork, RowPosition) 'Stav ke dni
    If Not IsEmpty(DatumSporeni) Then Range("DatumSporeni").Value = DateValue(DatumSporeni)  'Stav ke dni
    
    DatumNavrhu = GetValueByName("datnavrhu", DataWork, RowPosition) 'Datum návrhu
    If IsEmpty(DatumNavrhu) Then 'Když není vyplněn datum návrhu tak...
        DatumNavrhu = GetValueByName("datuz", DataWork, RowPosition) 'Datum návrhu dle datumu uzavření
    End If
    If Not IsEmpty(DatumNavrhu) Then Range("DatumNavrhu").Value = DateValue(DatumNavrhu)
    
    DatumSmlouvy = GetValueByName("datuz", DataWork, RowPosition)
    If Not IsEmpty(DatumSmlouvy) Then Range("DatumSmlouvy").Value = DateValue(DatumSmlouvy)  'Stav ke dni

    Range("CisloSmlouvy").Value = GetValueByName("smlouva", DataWork, RowPosition) 'Číslo smlouvy SS
    Range("CilovaCastka").Value = GetValueByName("cc", DataWork, RowPosition) 'CČ
    Range("NTarif").Value = GetNameTarif(GetValueByName("tarif", DataWork, RowPosition)) 'Tarif
    Range("Saldo").Value = GetValueByName("saldo", DataWork, RowPosition) 'Saldo
    Range("UkZhodnoceni").Value = GetValueByName("uz", DataWork, RowPosition) 'Ukazatel zhodnocení
    Range("MesVkladSS").Value = GetValueByName("vklad", DataWork, RowPosition) 'Splatka
    DataWork.Close
    CurrentWork.Activate
    CountVlogs
    isImport = True
    initImport = True
'    GetTarif
    Exit Sub
ErrorOpen:
    MsgBox ("Nepodařilo se otevřít soubor " + ImportDirectory + ImportFile)
ErrorCentrala:
    CurrentWork.Activate
End Sub

Sub stpod_Klepnout()
    UnlockSheet
    Range("STATNI_PODPORA").Value = (Sheets(Range("Modelovani_PDZ").Parent.Name).CheckBoxes("stpod") = 1)
    LockSheet
End Sub

Function TestSmlKontrola(ByVal SmlouvaNum As Double) As Boolean
    Dim CtrlSum As Integer
    Dim TmpSum As Double
    Dim Kontrola(0 To 9) As Double
    Dim StrSmlouva As String
    
    Kontrola(0) = 6
    Kontrola(1) = 1
    Kontrola(2) = 2
    Kontrola(3) = 4
    Kontrola(4) = 8
    Kontrola(5) = 5
    Kontrola(6) = 10
    Kontrola(7) = 9
    Kontrola(8) = 7
    Kontrola(9) = 3
    StrSmlouva = Trim(SmlouvaNum)
    StrPos = 1
    CtrlSum = -1
    Do While Len(StrSmlouva) <> 0
        If CtrlSum = -1 Then CtrlSum = 0
        TmpSum = SmlouvaNum - Fix(SmlouvaNum / 10) * 10
        CtrlSum = CtrlSum + TmpSum * Kontrola(StrPos Mod 10)
        StrSmlouva = Left(StrSmlouva, Len(StrSmlouva) - 1)
        If StrSmlouva <> "" Then SmlouvaNum = CDec(StrSmlouva)
        StrPos = StrPos + 1
    Loop
    TestSmlKontrola = CtrlSum Mod 11 = 0
End Function
Function TestMaker() As Boolean
TestMaker = True
End Function
Sub GetTarif()
    If Not ActualizeWorkbook Then Exit Sub
    Application.OnEntry = ""
    If Not IsError(Range("DatumSmlouvy").Value) Then
        If (isImport And initImport) Or Not isImport And Range("DatumSmlouvy").Value > 0 Then
            Status = ChkDatumZalozeni(Range("DatumSmlouvy").Value)
        Else
            Status = 0
        End If
        initImport = False
    End If
    Application.OnEntry = CurFileName & "!Makro.OnChange"
End Sub

Sub OnChange()
    If Not ActualizeWorkbook Then Exit Sub
    Application.OnEntry = ""

If Worksheets(Range("Modelovani_PDZ").Parent.Name).Name = ActiveSheet.Name Then
    Set CurrPosition = Selection
    'Worksheets(Range("Modelovani_PDZ").Parent.Name).CheckBoxes("1prcuhrada").Visible = Range("TypPreklenovaku").Value = 10 And Range("UverKlienta").Value = "P"

'    isChangeAction = (CurrPosition.Row = Range("NazevUveru").Row And CurrPosition.Column = Range("NazevUveru").Column)
'    isChangeAction = isChangeAction Or (CurrPosition.Row = Range("DatumZadosti").Row And CurrPosition.Column = Range("DatumZadosti").Column)
'    isChangeAction = isChangeAction Or (CurrPosition.Row = Range("NazevPreklenovaku").Row And CurrPosition.Column = Range("NazevPreklenovaku").Column)
'    isChangeAction = isChangeAction Or (CurrPosition.Row = Range("NTarif").Row And CurrPosition.Column = Range("NTarif").Column)
    
'    If isChangeAction Then
         Worksheets(Range("Modelovani_PDZ").Parent.Name).CheckBoxes("BonusPrc").Visible = Trim(Range("isBonusVisible").Text) & "none" <> "none"
         Worksheets(Range("Modelovani_PDZ").Parent.Name).CheckBoxes("BonusPrc").Enabled = Worksheets(Range("Modelovani_PDZ").Parent.Name).CheckBoxes("BonusPrc").Visible
'        If Not CheckBoxes("BonusPrc").Visible Then Range("prcuhrada").Value = False
'    End If


    isCountVlogs = (CurrPosition.Row = Range("Saldo").Row And CurrPosition.Column = Range("Saldo").Column)
    isCountVlogs = isCountVlogs Or (CurrPosition.Row = Range("CilovaCastka").Row And CurrPosition.Column = Range("CilovaCastka").Column)
    isCountVlogs = isCountVlogs Or (CurrPosition.Row = Range("NTarif").Row And CurrPosition.Column = Range("NTarif").Column)
    isCountVlogs = isCountVlogs Or (CurrPosition.Row = Range("DatumZadosti").Row And CurrPosition.Column = Range("DatumZadosti").Column)
    isCountVlogs = isCountVlogs Or (CurrPosition.Row = Range("NazevPreklenovaku").Row And CurrPosition.Column = Range("NazevPreklenovaku").Column)
    isCountVlogs = isCountVlogs Or (CurrPosition.Row = Range("NazevUveru").Row And CurrPosition.Column = Range("NazevUveru").Column)
    CurrentWorkUnProtect
    Sheets(Range("Slevy_PDZ").Parent.Name).Visible = Range("DatumZadosti").Value < 38078
    Sheets(Range("ManzelVypocet").Parent.Name).Visible = Range("isManzelDap").Value
    CurrentWorkProtect
    If isCountVlogs Then CountVlogs
    If CurrPosition.Row = Range("NazevUveru").Row And CurrPosition.Column = Range("NazevUveru").Column Then UpdateVis
'    If CurrPosition.Row = Range("DatumSmlouvy").Row And CurrPosition.Column = Range("DatumSmlouvy").Column Then GetTarif
    UnlockSheet
'    If Range("NazevPreklenovaku").Value <> Worksheets(Range("PreklenovaciUvery").Parent.Name).Cells(Range("PreklenovaciUvery").Row + IIf(Range("TypPreklenovaku").Value < 1, 1, IIf(Range("TypPreklenovaku").Value > Range("PreklenovaciUvery").Rows.Count, Range("PreklenovaciUvery").Rows.Count, Range("TypPreklenovaku").Value)) - 1, Range("PreklenovaciUvery").Column).Value Then
'        Range("NazevPreklenovaku").Value = Worksheets(Range("PreklenovaciUvery").Parent.Name).Cells(Range("PreklenovaciUvery").Row + IIf(Range("TypPreklenovaku").Value < 1, 1, IIf(Range("TypPreklenovaku").Value > Range("PreklenovaciUvery").Rows.Count, Range("PreklenovaciUvery").Rows.Count, Range("TypPreklenovaku").Value)) - 1, Range("PreklenovaciUvery").Column).Value
'    End If
    Range("NazevPreklenovaku").Value = ChkNameUver(Range("NazevPreklenovaku").Value, "VyberPreklenovaku")
    Range("NazevUveru").Value = ChkNameUver(Range("NazevUveru").Value, "PodUvery")
'    If Target.Address(1, 1) = Range("CisloSmlouvy").Address(1, 1) And isDBAccess And IsNumeric(Range("CisloSmlouvy").Text) Then
'       If Application.Version <> "12.0" Then ReadSmlouvaDB Range("CisloSmlouvy").Text
'        If Application.Version <> "12.0" Then ReadSmlouvaDB Range("CisloSmlouvy").Text
'    End If
    LockSheet
End If

Application.OnEntry = CurFileName & "!Makro.OnChange"
End Sub

Sub SetPrintArea(CurrentWorkSheet As Worksheet, PrintArea As String)
    On Error GoTo EndTisk
    With CurrentWorkSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        .PrintArea = PrintArea
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = "&""Arial CE,kurzíva""&7" & CurrentWork.Title
        .CenterFooter = ""
        .RightFooter = "&""Arial CE,kurzíva""&7Verze " & Replace(Worksheets("Upgrade").Range("D1").Value, ",", ".")
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.196850393700787)
        .BottomMargin = Application.InchesToPoints(0.196850393700787)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0.196850393700787)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    Exit Sub
EndTisk:
    MsgBox "Nemáte nainstalovanou tiskárnu. Nelze nastavit tisk", , "Chyba tiskárny"
    Err.Clear
End Sub
Function TestDateLow(DateTest As Date, DateWith As Range) As Boolean
TestDateLow = True
If IsDate(DateWith.Value) Then TestDateLow = DateTest <= DateWith.Value
End Function
Function TestDateHigh(DateTest As Date, DateWith As Range) As Boolean
TestDateHigh = True
If IsDate(DateWith.Value) Then TestDateHigh = DateTest >= DateWith.Value
End Function
Sub LockSheet()
If CountLock > 0 Then
    CountLock = CountLock - 1
Else
    CountLock = 0
End If
If Not Range("AdminMode").Value Then
    If CountLock = 0 Then Worksheets(Range("Modelovani_PDZ").Parent.Name).Protect Password:=Range("AdminPassword").Cells(1, 1).Value
End If
End Sub
Sub UnlockSheet()
    If CountLock = 0 Then Worksheets(Range("Modelovani_PDZ").Parent.Name).Unprotect Password:=Range("AdminPassword").Cells(1, 1).Value
    CountLock = CountLock + 1
End Sub
Function GetNameTarif(Tariff As Integer) As String
        GetNameTarif = Tariff
        PosTarif = Range("NEWTARIF").Column + 1
        For NextTarif = Range("NEWTARIF").Row To Range("NEWTARIF").Rows.Count + Range("NEWTARIF").Row - 1
            If Worksheets(Range("NEWTARIF").Parent.Name).Cells(NextTarif, PosTarif).Value = Tariff Then
                GetNameTarif = Worksheets(Range("NEWTARIF").Parent.Name).Cells(NextTarif, PosTarif - 1).Text 'Tarif
                Exit For
            End If
        Next
End Function
Function ChkNameUver(Uver As String, OblastUveru As String) As String
        ChkNameUver = Uver
        PosUver = Range(OblastUveru).Column
        For NextUver = Range(OblastUveru).Row To Range(OblastUveru).Rows.Count + Range(OblastUveru).Row - 1
            If Worksheets(Range(OblastUveru).Parent.Name).Cells(NextUver, PosUver).Text = Uver Then
                Exit For
            End If
        Next
        If NextUver >= Range(OblastUveru).Rows.Count + Range(OblastUveru).Row Then ChkNameUver = Worksheets(Range(OblastUveru).Parent.Name).Cells(Range(OblastUveru).Row, PosUver).Text
End Function

Sub initpasswords()
Dim UserRange As Range
    If Sheets("Data").Range("DA2").Text = "" And Sheets("Data").Range("DA3").Text = "" And Sheets("Data").Range("DA4").Text = "" And Sheets("Data").Range("DA5").Text = "" Then
        Sheets("Info").Range("UserPassword").Copy
        Sheets("Data").Paste Destination:=Sheets("Data").Range("DA2")
        Sheets("Info").Range("UserPassword").Offset(rowOffset:=0, columnOffset:=-1).Copy
        Sheets("Data").Paste Destination:=Sheets("Data").Range("DA2").Offset(rowOffset:=0, columnOffset:=-1)
    End If
    Set UserRange = Sheets("Data").Range("DA2:DA16")
    InitPassword UserPassword, UserRange
    InitPassword AdminPassword, Range("AdminPassword")
    If Not UserPassword.MustPassword And UserPassword.Password <> "" And Not Sheets("Info").Range("ChkHesloMode").Value Then
       MsgBox "Heslo neni povinné!" + Chr(13) + Chr(10) + "V případě že nechcete uvádět heslo" + Chr(13) + Chr(10) + "tak je možné heslo zrušit." + Chr(13) + Chr(10) + "Budou ale odstraněna klientská data v PDZ " + Chr(13) + Chr(10) + "a manipulace s nima bude zakázána)", vbOKOnly, "Heslo do systému"
       Sheets("Info").Range("ChkHesloMode").Value = True
    End If
    If TestPassword(UserPassword) Then
        ChangeUserPassword
    Else
        If UserPassword.Password = "" And Not Sheets("Info").Range("ChkHesloMode").Value Then
            If MsgBox("Heslo neni zadané!" + Chr(13) + Chr(10) + "Chcete aby jste zadaly heslo?" + Chr(13) + Chr(10) + "(v případě že neuvedete heslo" + Chr(13) + Chr(10) + "tak vám budou odstraněna klientská data v PDZ " + Chr(13) + Chr(10) + "a manipulace s nima bude zakázána)", vbYesNo, "Heslo do systému") = vbYes Then ChangeUserPassword
            Sheets("Info").Range("ChkHesloMode").Value = True
        End If
    End If
    If UserPassword.Password = "" Then
        CurrentWork.Sheets("Data").Unprotect Password:=Range("AdminPassword").Cells(1, 1).Value
        Sheets("Data").Range("AA:CY").ClearContents
        If Not Range("AdminMode").Value Then CurrentWork.Sheets("Data").Protect Password:=Range("AdminPassword").Cells(1, 1).Value
    End If
…

Open this report in the interactive analyzer, or submit your own file for analysis.