Attribute VB_Name = "AdmMakeXls"
Option Explicit

#If Win64 Then
    Public Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long
#Else
    Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long
#End If

Function ExistsNames(ByVal sName As String) As Boolean
    Dim i As Long
    
    If sName <> "" Then
        For i = 1 To Application.Names.Count
            If Application.Names(i).Name = sName Then
                ExistsNames = True
                Exit Function
            End If
        Next
    End If
    ExistsNames = False
End Function

Function ExistsNamesWS(ByVal ws As Worksheet, ByVal sName As String) As Boolean
    Dim i As Long
    
    If sName <> "" Then
        For i = 1 To ws.Names.Count
            If VBA.Mid(ws.Names(i).Name, VBA.InStr(ws.Names(i).Name, "!") + 1) = sName Then
                ExistsNamesWS = True
                Exit Function
            End If
        Next
    End If
    ExistsNamesWS = False
End Function

Function ExistsWorkbook(cName As String) As Boolean
    Dim twb As Workbook, bFlag As Boolean
    
    bFlag = False
    For Each twb In Application.Workbooks
        If twb.Name = cName Then bFlag = True
    Next twb
    ExistsWorkbook = bFlag
End Function

Function ExistsWorksheet(Wb As Workbook, cName As String) As Boolean
    Dim tws As Worksheet, bFlag As Boolean
    
    bFlag = False
    For Each tws In Wb.Sheets
        If tws.Name = cName Then bFlag = True
    Next tws
    ExistsWorksheet = bFlag
End Function

Function GetPathShort(cFileName As String) As String
    Dim nRes As Long, cPath As String
    
    cPath = VBA.String$(255, 0)
    nRes = GetShortPathName(cFileName, cPath, 254)
    GetPathShort = VBA.Left$(cPath, nRes)
End Function

Function GetStrParam(lcParam As String, ByVal lnParam As Integer, Optional cPart As String = "#") As String
Dim nPos1 As Integer, nPos2 As Integer, i As Long
    nPos1 = 0
    i = 1
    While i < lnParam
        nPos1 = VBA.InStr(nPos1 + 1, lcParam, cPart)
        If nPos1 = 0 Then
            GetStrParam = ""
            Exit Function
        End If
        i = i + 1
    Wend
    nPos2 = VBA.InStr(nPos1 + 1, lcParam, cPart)
    nPos2 = VBA.IIf(nPos2 = 0, VBA.Len(lcParam), nPos2 - 1)
    If nPos2 > nPos1 Then
        GetStrParam = VBA.Mid(lcParam, nPos1 + 1, nPos2 - nPos1)
    Else
        GetStrParam = ""
    End If
End Function

Public Sub InitMenu(ByVal cMode As String)
    Dim bFound As Boolean, cbar As Object, ToolbarAction As Object

    bFound = False
    For Each cbar In Application.CommandBars
        If cbar.Name = "AdmMakeXls" Then bFound = True
    Next
    If bFound Then Application.CommandBars("AdmMakeXls").Delete

    Set ToolbarAction = CommandBars.Add(Name:="AdmMakeXls", Position:=msoBarTop, Temporary:=True)
    With ToolbarAction.Controls.Add(Type:=msoControlButton)
        .FaceId = 342
        .Style = msoButtonIcon
        .Caption = "Выгрузить клиента Excel по администраторам"
        .OnAction = "MakeExcel"
    End With

    ToolbarAction.Enabled = True
    ToolbarAction.Visible = True
    Application.ThisWorkbook.Saved = True
End Sub

Sub MakeExcel()
    Dim oCurrApp As Application, oCurrBook As Workbook, oFolder _
        , oTmpBook As Workbook, cOutPath As String, nRow As Long, nCol As Long _
        , oData As Worksheet, cSono As String, oTmpSheet As Worksheet, bTmp As Boolean _
        , oActive As Worksheet, oTmpModel As Worksheet, nReport As Long, nBit As Long _
        , oSheet As Worksheet, cSheet As String
    
    Set oCurrApp = Application
    oCurrApp.DisplayAlerts = False
    oCurrApp.ScreenUpdating = False
    oCurrApp.Interactive = False
    
    Set oCurrBook = oCurrApp.ActiveWorkbook
    oFolder = oCurrApp.GetOpenFilename( _
        FileFilter:="Книга Excel 97-2003,*.xls", _
        Title:="Укажите книгу ""АДМИНИСТРАТОР-Д.КЛИЕНТ EXCEL""")

    If oFolder = False Then
        Exit Sub
    End If
    
    If oFolder = oCurrBook.FullName Then
        Exit Sub
    End If
    
    oCurrApp.Workbooks.Open (oFolder)
    Set oTmpBook = oCurrApp.ActiveWorkbook
    
    If oTmpBook.CodeName <> "admin_client" Then
        oTmpBook.Saved = True
        oTmpBook.Close (False)
        Set oTmpBook = Nothing
        
        Call VBA.MsgBox("Выгрузка не выполнена." _
            + VBA.vbNewLine + "Указанный файл не является книгой ""АДМИНИСТРАТОР-Д.КЛИЕНТ EXCEL""." _
            , VBA.vbOKOnly + VBA.vbExclamation, "Внимание")
        
        oCurrApp.ScreenUpdating = True
        oCurrApp.DisplayAlerts = True
        oCurrApp.Interactive = True
        Exit Sub
    End If
    
    oTmpBook.Saved = True
    oTmpBook.Close (False)
    Set oTmpBook = Nothing
    
    cOutPath = ""
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Укажите путь для выгрузки ..."
        If .Show = -1 Then cOutPath = .SelectedItems(1)
    End With
    
    If VBA.Dir(cOutPath, vbDirectory) = "" Then
        Exit Sub
    End If
    
    Set oData = oCurrBook.Worksheets(1)
    cSono = ""
    bTmp = False
    For nRow = 1 To 65000
        If oData.Cells(nRow, 1).Value = "" Then
            Exit For
        End If
        
        If cSono <> oData.Cells(nRow, 1).Value Then
            If bTmp And cSono <> "" Then
                If VBA.Dir(cOutPath + "\" + cSono, vbDirectory) = "" Then
                    Call VBA.MkDir(cOutPath + "\" + cSono)
                End If
                Application.StatusBar = "Сохранение книги: " + cOutPath + "\" + cSono + "\" + oTmpBook.Name
                oTmpBook.SaveAs (cOutPath + "\" + cSono + "\" + oTmpBook.Name)
                
                oTmpBook.Saved = True
                oTmpBook.Close (False)
                Set oTmpBook = Nothing
                bTmp = False
            End If
            
            oCurrApp.Workbooks.Open (oFolder)
            Set oTmpBook = oCurrApp.ActiveWorkbook
            cSono = oData.Cells(nRow, 1).Value
            bTmp = True
        End If
        
        If oData.Cells(nRow, 2).Value = "РЕКВИЗИТЫ" Then
            If ExistsWorksheet(oTmpBook, oData.Cells(nRow, 2).Value) Then
                Set oTmpSheet = oTmpBook.Worksheets(oData.Cells(nRow, 2).Value)
                
                If ExistsNamesWS(oTmpSheet, oData.Cells(nRow, 3).Value) Then
                    Call UnprotectSheet(oTmpSheet)
                    
                    oTmpSheet.Range(oData.Cells(nRow, 3).Value).Value = oData.Cells(nRow, 4).Value
                    If oData.Cells(nRow, 5).Value = 1 Then
                        Set oActive = Application.ActiveSheet
                        
                        oTmpSheet.Activate
                        oTmpSheet.Range(oData.Cells(nRow, 3).Value).Select
                        Selection.Locked = True
                        Selection.Interior.ColorIndex = 0
                        
                        oActive.Activate
                    End If
                    
                    Call ProtectSheet(oTmpSheet)
                Else
                    If oData.Cells(nRow, 3).Value = "REPORT" Then
                        nReport = VBA.Val(oData.Cells(nRow, 4).Value)
                        
                        For Each oSheet In oTmpBook.Worksheets
                            If VBA.InStr(oSheet.Name, "DIS_REPORT") > 0 Then
                                cSheet = "DIS_REPORT"
                            ElseIf VBA.InStr(oSheet.Name, "REPORT") > 0 Then
                                cSheet = "REPORT"
                            Else
                                cSheet = ""
                            End If
                            
                            If cSheet <> "" Then
                                nBit = VBA.Val(VBA.Replace(oSheet.Name, cSheet + "_", ""))
                                If nBit > 0 Then
                                    Call UnprotectBook(oTmpBook)
                                    If VBA.Abs(nReport And (2 ^ (nBit - 1))) > 0 Then
                                        oSheet.Name = "REPORT_" + VBA.Right("00" + VBA.Trim(VBA.Str(nBit)), 2)
                                    Else
                                        oSheet.Name = "DIS_REPORT_" + VBA.Right("00" + VBA.Trim(VBA.Str(nBit)), 2)
                                    End If
                                    Call ProtectBook(oTmpBook)
                                End If
                            End If
                        Next oSheet
                    Else
                        If ExistsWorksheet(oTmpBook, "MODEL") Then
                            Set oTmpModel = oTmpBook.Worksheets("MODEL")
                            If ScriptExists(oTmpModel, oData.Cells(nRow, 3).Value) Then
                                Call ScriptSet(oTmpModel, oData.Cells(nRow, 3).Value, oData.Cells(nRow, 4).Value)
                            End If
                        End If
                    End If
                End If
            End If
        Else
            If ExistsWorksheet(oTmpBook, oData.Cells(nRow, 2).Value) Then
                Set oTmpSheet = oTmpBook.Worksheets(oData.Cells(nRow, 2).Value)
                Call RecordCreate(oTmpSheet, oData.Cells(nRow, 3).Value, oData.Cells(nRow, 4).Value, oData.Cells(nRow, 6).Value)
            End If
        End If
        
        Application.StatusBar = "Обработано записей: " + VBA.Trim(VBA.Str(nRow))
    Next nRow
    Application.StatusBar = ""
    
    If bTmp And cSono <> "" Then
        If VBA.Dir(cOutPath + "\" + cSono, vbDirectory) = "" Then
            Call VBA.MkDir(cOutPath + "\" + cSono)
        End If
        Application.StatusBar = "Сохранение книги: " + cOutPath + "\" + cSono + "\" + oTmpBook.Name
        oTmpBook.SaveAs (cOutPath + "\" + cSono + "\" + oTmpBook.Name)
        
        oTmpBook.Saved = True
        oTmpBook.Close (False)
        Set oTmpBook = Nothing
        cSono = oData.Cells(nRow, 1).Value
        bTmp = False
    End If
    
    oCurrApp.ScreenUpdating = True
    oCurrApp.DisplayAlerts = True
    oCurrApp.Interactive = True

    Call VBA.MsgBox("Выгрузка по администраторам успешно произведена." _
        + VBA.vbNewLine + "Каталог выгрузки: " + cOutPath + "\" _
        , VBA.vbOKOnly + VBA.vbInformation, "Внимание")
End Sub

Sub ProtectBook(ByVal awb As Workbook)
    awb.Protect Password:="flvbylrkbtyn1076", Structure:=True ', Windows:=True
End Sub

Sub ProtectSheet(ByVal aws As Worksheet)
    aws.Protect Password:="flvbylrkbtyn1076", DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

Sub RecordCreate(ByVal oData As Worksheet, ByVal cCode As String, ByVal cValue As String, ByVal cFilter As String)
    Dim oActive As Worksheet, nTop As Long, nLeft As Long, nHeight As Long, nWidth As Long _
        , nRowData As Long

    If VBA.InStr("#КБК#ОКАТО#ПРИЗНАКИ#", "#" + oData.Name + "#") > 0 And ExistsNamesWS(oData, "TABLE") And ExistsNamesWS(oData, "BLANK_ROW") Then
        Call UnprotectSheet(oData)
        Set oActive = Application.ActiveSheet
        oData.Select
        
        nTop = oData.Range("TABLE").Cells(1, 1).Row
        nLeft = oData.Range("TABLE").Cells(1, 1).Column
        nHeight = oData.Range("TABLE").Rows.Count
        nWidth = oData.Range("TABLE").Columns.Count
        
        
        nRowData = nTop + nHeight - 1
        oData.Cells(nRowData, 1).Select
        oData.Rows(nRowData).Insert
        oData.Rows(oData.Range("BLANK_ROW").Cells(1, 1).Row).Copy
        oData.Rows(nRowData).PasteSpecial Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        oData.Rows(nRowData).Hidden = False
        oData.Rows(nRowData).Cells(1, 1).Select
        Application.CutCopyMode = False
        
        If ExistsNamesWS(oData, "CODE") Then
            oData.Cells(nRowData, oData.Range("CODE").Column).Value = cCode
        End If
        
        If ExistsNamesWS(oData, "NAME") Then
            oData.Cells(nRowData, oData.Range("NAME").Column).Value = cValue
        End If
        
        If ExistsNamesWS(oData, "FILTER") Then
            oData.Cells(nRowData, oData.Range("FILTER").Column).Value = cFilter
        End If
        
        oActive.Select
        Call ProtectSheet(oData)
    End If
End Sub

Function ScriptExists(ByVal oSheet As Worksheet, ByVal cIDScript As String) As Boolean
    Dim bRes As Boolean, n As Long
    
    bRes = False
    cIDScript = VBA.Trim(cIDScript)
    
    For n = 1 To oSheet.Scripts.Count
        If VBA.UCase(VBA.Trim(oSheet.Scripts(n).ID)) = VBA.UCase(VBA.Trim(cIDScript)) Then
            bRes = True
        End If
    Next n
    
    ScriptExists = bRes
End Function

Function ScriptGet(ByVal oSheet As Worksheet, ByVal cIDScript As String) As String
    Dim cRes As String

    cRes = ""
    cIDScript = VBA.Trim(cIDScript)
    
    If ScriptExists(oSheet, cIDScript) Then
        cRes = VBA.Trim(oSheet.Scripts(cIDScript).ScriptText)
    End If
    
    ScriptGet = cRes
End Function

Sub ScriptSet(ByVal oSheet As Worksheet, ByVal cIDScript As String, ByVal cValueScript As String)
    cIDScript = VBA.Trim(cIDScript)
    cValueScript = VBA.Trim(cValueScript)

    If Not ScriptExists(oSheet, cIDScript) Then
        oSheet.Scripts.Add Location:=2, Language:=2, ID:=cIDScript, ScriptText:=cValueScript
    Else
        oSheet.Scripts(cIDScript).ScriptText = cValueScript
    End If
End Sub

Sub UnprotectBook(Optional ByVal awb As Workbook = Nothing)
    If awb Is Nothing Then
        Application.ActiveWorkbook.Unprotect Password:="flvbylrkbtyn1076"
    Else
        awb.Unprotect Password:="flvbylrkbtyn1076"
    End If
End Sub

Sub UnprotectSheet(Optional ByVal aws As Worksheet = Nothing)
    If aws Is Nothing Then
        Application.ActiveSheet.Unprotect Password:="flvbylrkbtyn1076"
    Else
        aws.Unprotect Password:="flvbylrkbtyn1076"
    End If
End Sub

