Attribute VB_Name = "goszakaz"
Option Explicit

Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As Long) As Long
Public repPath As String, repName As String, dbPath As String
       
Sub MakeReport()
    Dim ws As Worksheet, wsn As Worksheet, wsd As Worksheet, wsb As Worksheet, wso As Worksheet, _
        i As Long, n As Long, iDataRowCount As Long, iDataColCount As Long, iLink As Long, iM2Pos As Long, _
        nm As name, curRange As Range, r As Range, iNextPos As Long, hWnd As Long, wsf As Worksheet, wsa As Worksheet

    Application.StatusBar = "Подождите ... Идет загрузка данных"
    hWnd = FindWindow("XLMAIN", 0)
    LockWindowUpdate (hWnd)
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False

    repPath = Trim(ThisWorkbook.Sheets(1).[a2].Value)
    repPath = repPath + IIf(repPath <> "", IIf(Mid(repPath, Len(repPath), 1) = "\", "", "\"), "")
    repName = Trim(ThisWorkbook.Sheets(1).[B2].Value)

    dbPath = Trim(ThisWorkbook.Sheets(1).[C2].Value)
    If dbPath <> "" Then
        dbPath = dbPath + IIf(Mid(dbPath, Len(dbPath), 1) = "\", "", "\")
    End If

    Set wsn = Application.ActiveWorkbook.Worksheets.Add
    Call LoadNastr("c_nastr.dbf", wsn.[a1])

    ' Открываем шаблон документа
    Workbooks.Open Filename:=repPath + repName
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    Range("A1").Select

    Select Case wsn.Range("TYPE_DOC").Value
    Case "EXCEL_CLIENT"
        Call LoadDBF("c_data.dbf", "dict_code_prod", False)    'продукция
        Call LoadDBF("c_data1.dbf", "dict_code_item", False)   'вид расхода
        Call LoadDBF("c_data2.dbf", "dict_place_zakaz", False) 'основания для котировок цен
        n = 1
        For Each ws In Application.ActiveWorkbook.Worksheets
            If VBA.Left(ws.name, 6) = "blank_" And ws.Visible = xlSheetVeryHidden Then
                i = VBA.Val(VBA.Right(ws.name, VBA.Len(ws.name) - 6))
                If wsn.Range("nCheck_" + VBA.Trim(VBA.Str(i))).Value = 0 Then
                    ws.Visible = xlSheetVisible
                    ws.Delete
                Else
                    ws.Name = "blank" + VBA.Trim(VBA.Str(n))
                    n = n + 1
                End If
            End If
        Next ws

    Case "DOCUMENTS_GOS_PRICE"
        Set wsb = Application.ActiveWorkbook.Activesheet
        iM2Pos = 0
        For Each nm In wsb.names
            If VBA.InStr(nm.name, "!m2_") > 0 And iM2Pos = 0 Then _
                iM2Pos = wsb.Range(nm.name).row
        Next nm

        Set wsd = Application.ActiveWorkbook.Worksheets.Add
        wsd.Name = "c_data"
        Call LoadDBF("c_data.dbf", "c_data", False)
        wsd.Visible = xlSheetVisible

        iDataRowCount = wsd.Range("data").Rows.Count
        iDataColCount = wsd.Range("data").Columns.Count
        For i = 1 To iDataColCount
            wsd.names.Add name:=wsd.Cells(1,i).Text, RefersToR1C1:="=" & wsd.name & "!" & wsd.Cells(1,i).Address(ReferenceStyle:=xlR1C1)
        Next i

        iLink = 0
        If ExistsNamesWS(wsd, "link_doc") Then
            For i = 2 To iDataRowCount
                If iLink <> wsd.Cells(i, wsd.Range("link_doc").Column).Value Then
                    iLink = wsd.Cells(i, wsd.Range("link_doc").Column).Value
                    wsb.Select
                    wsb.Copy After:=wsb
                    Set wso = Application.ActiveWorkbook.Activesheet
                    If iM2Pos = 0 Then
                        Set curRange = wso.Rows("1:65535")
                    Else
                        Set curRange = wso.Rows("1:" & (iM2Pos-1))
                    End If
                    Set r = curRange.Find(">>>", LookIn:=xlValues, LookAt:=xlPart)
                    If Not r Is Nothing Then
                        Do
                            If ExistsNamesWS(wsd, VBA.Mid(r.Value, 4)) Then
                                r.Value = wsd.Cells(i, wsd.Range(VBA.Mid(r.Value, 4)).Column).Value
                            Else
                                r.Value = Null
                            End IF
                            Set r = curRange.FindNext(r)
                        Loop While Not r Is Nothing
                    End If
                    Set r = Nothing
                    iNextPos = iM2Pos + 1
                End If
                If iM2Pos <> 0 Then
                    With wso
                        .Rows(iNextPos).Insert
                        .Rows(iM2Pos).Copy
                        .Rows(iNextPos).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        .Rows(iNextPos).Hidden = False
                        Application.CutCopyMode = False
                        .Cells(iNextPos, 1).Select
                    End With
                    Set curRange = wso.Rows(iNextPos)
                    Set r = curRange.Find(">>>", LookIn:=xlValues, LookAt:=xlPart)
                    If Not r Is Nothing Then
                        Do
                            If ExistsNamesWS(wsd, VBA.Mid(r.Value, 4)) Then
                                r.Value = wsd.Cells(i, wsd.Range(VBA.Mid(r.Value, 4)).Column).Value
                            Else
                                r.Value = Null
                            End IF
                            Set r = curRange.FindNext(r)
                        Loop While Not r Is Nothing
                    End If
                    Set r = Nothing
                    iNextPos = iNextPos + 1
                End If
            Next i
        End If
        VBA.Randomize
        For Each ws In Application.ActiveWorkbook.Worksheets
            ws.Protect Password:=MkChar(VBA.Int(VBA.Rnd()*100000)*10000+VBA.Int(VBA.Rnd()*100000),10), DrawingObjects:=True, Contents:=True
        Next ws
        wsd.Delete
        wsb.Delete

    Case "EXCEL_CLIENT807"
        Call LoadDBF("c_data.dbf", "DICTIONARY_RATE_GOSZAKAZ", True)
        Call LoadDBF("c_data1.dbf", "DICTIONARY_DEPARTMENT", True)
        Call LoadDBF("c_data2.dbf", "DICTIONARY_DIVISION", True)
        Call LoadDBF("c_data3.dbf", "DICTIONARY_TARGET_ITEM", True)
        Call LoadDBF("c_data4.dbf", "DICTIONARY_EXPEND", True)
        Call LoadDBF("c_data5.dbf", "DICTIONARY_ITEM", True)
        Call LoadDBF("c_data6.dbf", "DICTIONARY_CURRENCY", True)
        Call LoadDBF("c_data7.dbf", "DICTIONARY_ED_IZM", True)
        Call LoadDBF("c_data8.dbf", "DICTIONARY_OKSM", True)

        'FORM_SK
        If ExistsWorksheet(Application.ActiveWorkbook, "FORM_SK") Then
            Set wsf = Application.ActiveWorkbook.Worksheets("FORM_SK")
            Set wsa = Application.ActiveSheet
            wsf.Activate
            wsf.Visible = xlSheetVisible
            Call UnprotectSheet(wsf)

            'Закрыть "Номер извещения о проведении торгов"
            If wsn.Range("nCheck_1").Value = 1 Then
                If ExistsNamesWS(wsf, "NUM_IZV") Then
                    wsf.Range("NUM_IZV").Select
                    Selection.Locked = True
                    Selection.FormulaHidden = False
                    Selection.ClearComments
                End If
            End If

            'Закрыть "Номер реестровой записи"
            If wsn.Range("nCheck_2").Value = 1 Then
                If ExistsNamesWS(wsf, "NUM_BX") Then
                    wsf.Range("NUM_BX").Select
                    Selection.Locked = True
                    Selection.FormulaHidden = False
                    Selection.ClearComments
                End If
            End If

            'Закрыть "Дата регистрации"
            If wsn.Range("nCheck_3").Value = 1 Then
                If ExistsNamesWS(wsf, "DATE_REG") Then
                    wsf.Range("DATE_REG").Select
                    Selection.Locked = True
                    Selection.FormulaHidden = False
                    Selection.ClearComments
                End If
            End If

            'Источник финансирования
            If VBA.Trim(wsn.Range("cText_4").Value) <> "" Then
                If ExistsNamesWS(wsf, "NAME_PUB") Then
                    wsf.Range("NAME_PUB").Select
                    Selection.Locked = True
                    Selection.FormulaHidden = False
                    Selection.ClearComments
                    wsf.Range("NAME_PUB") = VBA.Trim(wsn.Range("cText_4").Value)
                End If
            End If

            Call ProtectSheet(wsf)
            wsf.Visible = xlSheetVeryHidden
            wsa.Activate
            Set wsa = Nothing
            Set wsf = Nothing
        End If

        'Реквизиты
        If ExistsWorksheet(Application.ActiveWorkbook, "Реквизиты") Then
            Set wsf = Application.ActiveWorkbook.Worksheets("Реквизиты")
            Set wsa = Application.ActiveSheet
            wsf.Activate
            wsf.Visible = xlSheetVisible
            Call UnprotectSheet(wsf)

            'Код ОФК
            If VBA.Trim(wsn.Range("KOD_TOFK").Value) <> "" Then
                If ExistsNamesWS(wsf, "KOD_TOFK") Then
                    wsf.Range("KOD_TOFK").Select
                    Selection.Locked = True
                    Selection.FormulaHidden = False
                    Selection.ClearComments
                    wsf.Range("KOD_TOFK") = VBA.Trim(wsn.Range("KOD_TOFK").Value)
                End If
            End If

            'Наименование ОФК
            If VBA.Trim(wsn.Range("NAME_TOFK").Value) <> "" Then
                If ExistsNamesWS(wsf, "NAME_TOFK") Then
                    wsf.Range("NAME_TOFK").Select
                    Selection.Locked = True
                    Selection.FormulaHidden = False
                    Selection.ClearComments
                    wsf.Range("NAME_TOFK") = VBA.Trim(wsn.Range("NAME_TOFK").Value)
                End If
            End If

            Call ProtectSheet(wsf)
            wsa.Activate
            Set wsa = Nothing
            Set wsf = Nothing
        End If
    End Select

    wsn.Delete
    LockWindowUpdate (0)
    Application.ScreenUpdating = True
    Application.StatusBar = False
    Application.DisplayAlerts = True
    Application.Visible = True
    Application.Calculation = xlCalculationAutomatic
    Application.ActiveWorkbook.Saved = True
    Application.ThisWorkbook.Windows(1).Visible = False
    Application.ThisWorkbook.Saved = True

    i = Application.Run(Application.ActiveWorkbook.Name + "!show_work_menu")
End Sub

Sub LoadDBF(ByVal dbName As String, ByVal strSheet As String, ByVal bDelHeaders As Boolean)
    Dim qt As QueryTable, odbcDriver As String, odbcstr As String, wsi As Worksheet
    Dim dbSelect As String, n As Integer, wso As Worksheet, refers As String
    Set wsi = Application.ActiveWorkbook.Worksheets.Add
    dbSelect = "SELECT * FROM " + dbName
    odbcDriver = GetODBCDriver()
    dbPath = IIf(dbPath = "", ThisWorkbook.Path + "\", dbPath)
    odbcstr = "ODBC;" + _
        "Driver=" + odbcDriver + ";" + _
        "UID=admin;SourceType=DBF;" + _
        "DefaultDir=" + dbPath + "\;" + _
        "DBQ=" + dbPath + "\;" + _
        "SourceDB=" + dbPath + "\;"
    Set qt = wsi.QueryTables.Add(odbcstr, wsi.Range("A1"), dbSelect)
    qt.BackgroundQuery = False
    qt.FieldNames = True
    On Error GoTo Err1
    qt.Refresh
    On Error GoTo Err1

    Set wso = Application.ActiveWorkbook.Worksheets(strSheet)
    wso.Visible = xlSheetVisible
    Call UnprotectSheet(wso)
    wsi.Range("ExternalData_1").Select
    Selection.Copy
    wso.Select
    wso.Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    refers = wsi.names("ExternalData_1").RefersToR1C1
    refers = VBA.Right(refers,VBA.Len(refers)-VBA.InStr(refers,"!"))
    wso.names.Add name:="data", RefersToR1C1:="=" & wso.name & "!" & refers
    wso.names.Add name:=wso.name, RefersToR1C1:="=" & wso.name & "!" & refers
    if bDelHeaders Then
        wso.Rows("1:1").Select
        Selection.Delete Shift:=xlUp
    End If
    Call ProtectSheet(wso)
    wso.Visible = xlSheetVeryHidden
    wsi.Delete
    GoTo ExitProc
Err1:
    wsi.Delete
    n = MsgBox("Ошибка загрузки данных!", vbCritical + vbOKOnly, "Ошибка")
    GoTo ExitProc
ExitProc:
    Set wsi = Nothing
    Set qt = Nothing
End Sub

Sub LoadNastr(dbName As String, lrNastr As Range)
Dim i As Long, lnNastrRow As Integer, lnNastrCol As Integer, qt As QueryTable, _
    n As Integer, lcName As String, lcText As String, rowsCount As Integer
    dbPath = IIf(dbPath = "", ThisWorkbook.Path + "\", dbPath)
    If Dir(dbPath + dbName, vbNormal) <> "" Then
        lnNastrRow = lrNastr.Row
        lnNastrCol = lrNastr.Column
        
        lrNastr.Parent.Activate
        Set qt = lrNastr.Parent.QueryTables.Add("ODBC;" + _
            "Driver=" + GetODBCDriver() + ";" + _
            "UID=admin;SourceType=DBF;" + _
            "DefaultDir=" + dbPath + "\;" + _
            "DBQ=" + dbPath + "\;" + _
            "SourceDB=" + dbPath + "\;", lrNastr, "SELECT * FROM " + dbName)
            
        qt.BackgroundQuery = False
        qt.FieldNames = True
        On Error GoTo Err1
        qt.Refresh
        On Error GoTo 0
        rowsCount = qt.ResultRange.Rows.Count
        lrNastr.Parent.Parent.Names.Add Name:="NastrFields", _
         RefersToR1C1:="=" + lrNastr.Parent.Name + "!R" + Trim(Str(lnNastrRow + 1)) + "C" + Trim(Str(lnNastrCol)) + ":R" + Trim(Str(lnNastrRow + rowsCount)) + "C" + Trim(Str(lnNastrCol))
        For i = 1 To rowsCount
            lcName = lrNastr.Parent.Cells(lnNastrRow + i, lnNastrCol)
            If lcName <> "" Then
                lrNastr.Parent.Parent.Names.Add Name:=lcName, _
                   RefersToR1C1:="=" + lrNastr.Parent.Name + "!R" + Trim(Str(lnNastrRow + i)) + "C" + Trim(Str(lnNastrCol + 1))
                If Mid(lcName, 1, 1) <> "c" Then
                    With lrNastr.Parent.Cells(lnNastrRow + i, lnNastrCol + 1)
                        If VarType(.Value) = vbString Then ' Титов
                            lcText = .Value
                        Else
                            lcText = .Text
                        End If
                        .FormulaLocal = IIf(Mid(lcText, 1, 1) = "=", " ", "") + lcText
                    End With
                End If
            End If
        Next i
        GoTo ExitProc
Err1:
        n = MsgBox("Ошибка загрузки данных!", vbCritical + vbOKOnly, "Ошибка")
ExitProc:
    End If
    Set qt = Nothing
End Sub

Function ExistsNamesWS(ByVal ws As Worksheet, ByVal sName As String) As Boolean
    Dim i As Integer
    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

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

Sub UnprotectSheet(ByVal aws As Worksheet)
    aws.Unprotect Password:="ujcpfrfprkbtyn"
End Sub

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
